Section Metatheorems.
Require Import NaturalNumbers.

(* Theorem 2.1 (1) *)
Theorem Plus_unit_l :
    forall n : peano, Plus Z n n.
Proof.
    apply P_Zero.
Qed.

(* Theorem 2.1 (2) *)
Theorem Plus_unit_r :
    forall n : peano, Plus n Z n.
Proof.
    induction n as [| n' H_n'].

        (* Case : n = Z *)
        apply P_Zero.

        (* Case : n = S n' *)
        apply (P_Succ _ _ _ H_n').
Qed.

(* Theorem 2.2 *)
Theorem Plus_uniq :
    forall n1 n2 n3 n4 : peano, Plus n1 n2 n3 -> Plus n1 n2 n4 -> n3 = n4.
Proof.
    intros n1 n2.
    induction n1 as [| n1' H'].

        (* Case : n1 = Z *)
        intros n3 n4 H3 H4.
        inversion H3; subst.
        inversion H4; subst.
        reflexivity.

        (* Case : n1 = S n1' *)
        intros n3 n4 H3 H4.
        inversion H3 as [| t1 t2 n3' H3']; subst.
        inversion H4 as [| t1 t2 n4' H4']; subst.
        assert (n3' = n4') by apply (H' _ _ H3' H4').
        subst.
        reflexivity.
Qed.

(* Theorem 2.3 *)
Theorem Plus_close :
    forall n1 n2 : peano, exists n3 : peano, Plus n1 n2 n3.
Proof.
    intros n1 n2.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        exists n2.
        apply P_Zero.

        (* Case : n1 = S n1' *)
        destruct H1 as [n3 H3].
        exists (S n3).
        apply (P_Succ _ _ _ H3).
Qed.

(* Exercise 2.2 *)
Lemma P_Succ_r :
    forall n1 n2 n3 : peano, Plus n1 n2 n3 -> Plus n1 (S n2) (S n3).
Proof.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        intros n2 n3 H.
        inversion H; subst.
        apply P_Zero.

        (* Case : n1 = S n' *)
        intros n2 n3 H.
        inversion H; subst.
        apply P_Succ.
        apply (H1 _ _ H2).
Qed.

(* Theorem 2.4 *)
Theorem Plus_comm :
    forall n1 n2 n3 : peano, Plus n1 n2 n3 -> Plus n2 n1 n3.
Proof.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        intros n2 n3 H.
        inversion H; subst.
        apply Plus_unit_r.

        (* Case : n1 = S n1' *)
        intros n2 n3 H.
        inversion H; subst.
        apply P_Succ_r.
        apply (H1 _ _ H2).
Qed.

(* Theorem 2.5 *)
Theorem Plus_assoc :
    forall n1 n2 n3 n4 n5 : peano,
    Plus n1 n2 n4 -> Plus n4 n3 n5 ->
    exists n6 : peano, Plus n2 n3 n6 /\ Plus n1 n6 n5.
Proof.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        intros n2 n3 n4 n5 H4 H5.
        assert (exists n6, Plus n2 n3 n6) as H6 by apply Plus_close.
        destruct H6 as [n6 H6].
        exists n6.
        split.

            (* Plus n2 n3 n6 *)
            apply H6.

            (* Plus Z n6 n5 *)
            inversion H4; subst.
            assert (n5 = n6) as H56 by apply (Plus_uniq _ _ _ _ H5 H6).
            subst.
            apply P_Zero.

        (* Case : n1 = S n1' *)
        intros n2 n3 n4 n5 H4 H5.
        assert (exists n6, Plus n2 n3 n6) as H6 by apply Plus_close.
        destruct H6 as [n6 H6].
        exists n6.
        split.

            (* Plus n2 n3 n6 *)
            apply H6.

            (* Plus (S n1') n6 n5 *)
            inversion H4 as [| A B n4' H4' E F G]; subst.
            inversion H5 as [| A B n5' H5' E F G]; subst.
            apply P_Succ.
            specialize (H1 n2 n3 n4' n5' H4' H5').
            destruct H1 as [n7 [H7 H1]].
            assert (n6 = n7) by apply (Plus_uniq _ _ _ _ H6 H7).
            subst.
            apply H1.
Qed.

(* Theorem 2.6 *)
Theorem Times_uniq :
    forall n1 n2 n3 n4 : peano, Times n1 n2 n3 -> Times n1 n2 n4 -> n3 = n4.
Proof.
    intros n1 n2.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        intros n3 n4 H3 H4.
        inversion H3; subst.
        inversion H4; subst.
        reflexivity.

        (* Case : n1 = S n1' *)
        intros n3 n4 H3 H4.
        inversion H3 as [| t1 t2 x t3 Hxt Hxp]; subst.
        inversion H4 as [| t1 t2 y t3 Hyt Hyp]; subst.
        assert (x = y) by apply (H1 _ _ Hxt Hyt); subst.
        apply (Plus_uniq _ _ _ _ Hxp Hyp).
Qed.

(* Theorem 2.7 *)
Theorem Times_close :
    forall n1 n2 : peano, exists n3 : peano, Times n1 n2 n3.
Proof.
    intros n1 n2.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        exists Z.
        apply T_Zero.

        (* Case : n1 = S n1' *)
        destruct H1 as [n3 H3].
        assert (exists n4, Plus n2 n3 n4) by apply Plus_close.
        destruct H as [n4 H4].
        exists n4.
        apply (T_Succ _ _ n3 _ H3 H4).
Qed.

(* Theorem 2.8 (1) *)
Theorem Times_zero_l :
    forall n : peano, Times Z n Z.
Proof.
    apply T_Zero.
Qed.

(* Theorem 2.8 (2) *)
Theorem Times_zero_r :
    forall n : peano, Times n Z Z.
Proof.
    induction n as [| n' H].

        (* Case : n = Z *)
        apply T_Zero.

        (* Case : n = S n' *)
        apply (T_Succ _ _ Z _ H).
        apply P_Zero.
Qed.

Lemma T_Zero_r :
    forall n : peano, Times n Z Z.
Proof.
    induction n as [| n' H].

        (* Case : n = Z *)
        apply T_Zero.

        (* Case : n = S n' *)
        apply (T_Succ _ _ Z _ H).
        apply P_Zero.
Qed.

Lemma T_Succ_r :
    forall n1 n2 n3 n4 : peano,
    Times n1 n2 n3 -> Plus n1 n3 n4 -> Times n1 (S n2) n4.
Proof.
Admitted.

(* Theorem 2.9 *)
Theorem Times_comm :
    forall n1 n2 n3 : peano, Times n1 n2 n3 -> Times n2 n1 n3.
Proof.
    induction n1 as [| n1' H1].

        (* Case : n1 = Z *)
        intros n2 n3 H.
        inversion H; subst.
        apply T_Zero_r.

        (* Case : n1 = S n' *)
        intros n2 n3 H.
        inversion H as [| t1 t2 x t3 Hxt Hxp]; subst.
        assert (Times n2 n1' x) as Hxt' by apply (H1 _ _ Hxt).
        apply (T_Succ_r _ _ x _ Hxt' Hxp).
Qed.

(* Theorem 2.10 *)
Theorem Times_assoc :
    forall n1 n2 n3 n4 n5 : peano,
    Times n1 n2 n4 -> Times n4 n3 n5 ->
    exists n6 : peano, Times n2 n3 n6 /\ Times n1 n6 n5.
Proof.
Admitted.

(* Theorem 2.11 (CompareNat1) *)
Theorem LessThan1_Z_Sn :
    forall n : peano, LessThan1 Z (S n).
Proof.
    induction n as [| n' H'].

        (* Case : n = Z *)
        apply L1_Succ.

        (* Case : n = S n' *)
        apply (L1_Trans _ (S n') _ H').
        apply L1_Succ.
Qed.

(* Theorem 2.11 (CompareNat2) *)
Theorem LessThan2_Z_Sn :
    forall n : peano, LessThan2 Z (S n).
Proof.
    apply L2_Zero.
Qed.

(* Theorem 2.11 (CompareNat3) *)
Theorem LessThan3_Z_Sn :
    forall n : peano, LessThan3 Z (S n).
Proof.
    induction n as [| n' H].

        (* Case : n = Z *)
        apply L3_Succ.

        (* Case : n = S n' *)
        apply (L3_SuccR _ _ H).
Qed.

(* Theorem 2.12 (CompareNat1) *)
Theorem LessThan1_prev :
    forall n1 n2 : peano, LessThan1 (S n1) (S n2) -> LessThan1 n1 n2.
Proof.
Admitted.

(* Theorem 2.12 (CompareNat2) *)
Theorem LessThan2_prev :
    forall n1 n2 : peano, LessThan2 (S n1) (S n2) -> LessThan2 n1 n2.
Proof.
Admitted.

(* Theorem 2.12 (CompareNat3) *)
Theorem LessThan3_prev :
    forall n1 n2 : peano, LessThan3 (S n1) (S n2) -> LessThan3 n1 n2.
Proof.
Admitted.

(* Theorem 2.13 (CompareNat1) *)
Theorem LessThan1_trans :
    forall n1 n2 n3 : peano,
    LessThan1 n1 n2 -> LessThan1 n2 n3 -> LessThan1 n1 n3.
Proof.
    apply L1_Trans.
Qed.

(* Theorem 2.13 (CompareNat2) *)
Theorem LessThan2_trans :
    forall n1 n2 n3 : peano,
    LessThan2 n1 n2 -> LessThan2 n2 n3 -> LessThan2 n1 n3.
Proof.
Admitted.

(* Theorem 2.13 (CompareNat3) *)
Theorem LessThan3_trans :
    forall n1 n2 n3 : peano,
    LessThan3 n1 n2 -> LessThan3 n2 n3 -> LessThan3 n1 n3.
Proof.
Admitted.

(* Theorem 2.14 (1) (2) *)
Theorem LessThan_equiv_1_2 :
    forall n1 n2 : peano, LessThan1 n1 n2 <-> LessThan2 n1 n2.
Proof.
Admitted.

(* Theorem 2.14 (2) (3) *)
Theorem LessThan_equiv_2_3 :
    forall n1 n2 : peano, LessThan2 n1 n2 <-> LessThan3 n1 n2.
Proof.
Admitted.

(* Theorem 2.14 (1) (3) *)
Theorem LessThan_equiv_1_3 :
    forall n1 n2 : peano, LessThan1 n1 n2 <-> LessThan3 n1 n2.
Proof.
Admitted.

(* Theorem 2.15 *)
Theorem EvalTo_total :
    forall e : Exp, exists n : peano, EvalTo e n.
Proof.
    induction e as [ n1 | e1 [n1 H1] e2 [n2 H2] | e1 [n1 H1] e2 [n2 H2]].

        (* Case : e = ENum n1 *)
        exists n1.
        apply E_Const.

        (* Case : e = EPlus e1 e2 *)
        assert (exists n, Plus n1 n2 n) by apply Plus_close.
        destruct H as [n H].
        exists n.
        apply (E_Plus _ _ n1 n2 _ H1 H2 H).

        (* Case : e = ETimes e1 e2 *)
        assert (exists n, Times n1 n2 n) by apply Times_close.
        destruct H as [n H].
        exists n.
        apply (E_Times _ _ n1 n2 _ H1 H2 H).
Qed.

(* Theorem 2.16 *)
Theorem EvalTo_uniq :
    forall (e : Exp) (n1 n2 : peano), EvalTo e n1 -> EvalTo e n2 -> n1 = n2.
Proof.
    induction e as [n | e1 He1 e2 He2 | e1 He1 e2 He2].

        (* Case : e = ENum n *)
        intros n1 n2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        reflexivity.

        (* Case : e = EPlus e1 e2 *)
        intros n1 n2 H1 H2.
        inversion H1 as [| t1 t2 n11' n12' H H11' H12' H1' |]; subst.
        inversion H2 as [| t1 t2 n21' n22' H H21' H22' H2' |]; subst.
        assert (n11' = n21') by apply  (He1 _ _ H11' H21'); subst.
        assert (n12' = n22') by apply  (He2 _ _ H12' H22'); subst.
        apply (Plus_uniq _ _ _ _ H1' H2').

        (* Case : e = ETimes e1 e2 *)
        intros n1 n2 H1 H2.
        inversion H1 as [| | t1 t2 n11' n12' H H11' H12' H1']; subst.
        inversion H2 as [| | t1 t2 n21' n22' H H21' H22' H2']; subst.
        assert (n11' = n21') by apply  (He1 _ _ H11' H21'); subst.
        assert (n12' = n22') by apply  (He2 _ _ H12' H22'); subst.
        apply (Times_uniq _ _ _ _ H1' H2').
Qed.

(* Theorem 2.17 *)
Theorem EPlus_comm :
    forall (e1 e2 : Exp) (n : peano),
    EvalTo (EPlus e1 e2) n -> EvalTo (EPlus e2 e1) n.
Proof.
    intros e1 e2 n H.
    inversion H as [| t1 t2 n1 n2 t3 H1 H2 Hp t4 |]; subst.
    assert (Plus n2 n1 n) as Hp' by apply (Plus_comm _ _ _  Hp).
    apply (E_Plus _ _ _ _ _ H2 H1 Hp').
Qed.

(* Theorem 2.18 *)
Theorem EPlus_assoc :
    forall (e1 e2 e3 : Exp) (n : peano),
    EvalTo (EPlus (EPlus e1 e2) e3) n -> EvalTo (EPlus e1 (EPlus e2 e3)) n.
Proof.
Admitted.

(* Theorem 2.19 *)
Theorem ETimes_comm :
    forall (e1 e2 : Exp) (n : peano),
    EvalTo (ETimes e1 e2) n -> EvalTo (ETimes e2 e1) n.
Proof.
    intros e1 e2 n H.
    inversion H as [| | t1 t2 n1 n2 t3 H1 H2 Ht t4]; subst.
    assert (Times n2 n1 n) as Ht' by apply (Times_comm _ _ _ Ht).
    apply (E_Times _ _ _ _ _ H2 H1 Ht').
Qed.

(* Theorem 2.20 *)
Theorem ETimes_assoc :
    forall (e1 e2 e3 : Exp) (n : peano),
    EvalTo (ETimes (ETimes e1 e2) e3) n -> EvalTo (ETimes e1 (ETimes e2 e3)) n.
Proof.
Admitted.

(* Theorem 2.21 *)
Theorem ReduceTo_progress :
    forall e : Exp,
    (exists n : peano, e = ENum n) \/ (exists e' : Exp, ReduceTo e e').
Proof.
    induction e as [p | e1 H1 e2 H2 | e1 H1 e2 H2].

        (* Case : e = ENum p *)
        left.
        exists p.
        reflexivity.

        (* Case : e = EPlus e1 e2 *)
        right.
        destruct H1 as [[n1 H1] | [e1' H1]].

            (* Case : e1 = Enum n1 *)
            destruct H2 as [[n2 H2] | [e2' H2]]; subst.

                (* Case : e2 = ENum n2 *)
                assert (exists n, Plus n1 n2 n) as H by apply Plus_close.
                destruct H as [n H].
                exists (ENum n).
                apply (R_Plus _ _ _ H).

                (* Case : ReduceTo e2 e2' *)
                exists (EPlus (ENum n1) e2').
                apply (R_PlusR _ _ _ H2).

            (* Case : ReduceTo e1 e1' *)
            exists (EPlus e1' e2).
            apply (R_PlusL _ _ _ H1).

        (* Case : e = ETimes e1 e2 *)
        right.
        destruct H1 as [[n1 H1] | [e1' H1]].

            (* Case : e1 = Enum n1 *)
            destruct H2 as [[n2 H2] | [e2' H2]]; subst.

                (* Case : e2 = ENum n2 *)
                assert (exists n, Times n1 n2 n) as H by apply Times_close.
                destruct H as [n H].
                exists (ENum n).
                apply (R_Times _ _ _ H).

                (* Case : ReduceTo e2 e2' *)
                exists (ETimes (ENum n1) e2').
                apply (R_TimesR _ _ _ H2).

            (* Case : ReduceTo e1 e1' *)
            exists (ETimes e1' e2).
            apply (R_TimesL _ _ _ H1).
Qed.

(* Theorem 2.22 (incorrect?) *)
Theorem ReduceTo_confl :
    forall e1 e2 e3 : Exp,
    ReduceTo e1 e2 -> ReduceTo e1 e3 ->
    exists e4 : Exp, ReduceTo e2 e4 /\ ReduceTo e3 e4.
Proof.
Admitted.

(* Theorem 2.23 *)
Theorem DetReduceTo_uniq :
    forall e e' e'' : Exp, DetReduceTo e e' -> DetReduceTo e e'' -> e' = e''.
Proof.
Admitted.

(* Theorem 2.24 *)
Theorem DetReduceTo_ReduceTo :
    forall e e' : Exp, DetReduceTo e e' -> ReduceTo e e'.
Proof.
    intros e e' H.
    induction H as [n1 n2 n3 H | n1 n2 n3 H |
                    e1 e1' e2 _ H' | e1 e2 e2' _ H' |
                    e1 e1' e2 _ H' | e1 e2 e2' _ H'].

        (* Case : e = EPlus (ENum n1) (ENum n2) *)
        apply (R_Plus _ _ _ H).

        (* Case : e = ETimes (ENum n1) (ENum n2) *)
        apply (R_Times _ _ _ H).

        (* Case : DetReduceTo e1 e1', e = EPlus e1 e2 *)
        apply (R_PlusL _ _ _ H').

        (* Case : DetReduceTo e2 e2', e = EPlus e1 e2 *)
        apply (R_PlusR _ _ _ H').

        (* Case : DetReduceTo e1 e1', e = ETimes e1 e2 *)
        apply (R_TimesL _ _ _ H').

        (* Case : DetReduceTo e2 e2', e = ETimes e1 e2 *)
        apply (R_TimesR _ _ _ H').
Qed.

(* Theorem 2.25 *)
Theorem ReduceTo_weak_normal :
    forall e : Exp, exists n : peano, MultiReduceTo e (ENum n).
Proof.
Admitted.

(* FIXME: Theorem 2.26 *)

(* Theorem 2.27 *)
Theorem EvalTo_MultiReduceTo :
    forall (e : Exp) (n : peano), EvalTo e n -> MultiReduceTo e (ENum n).
Proof.
Admitted.

(* Theorem 2.28 *)
Theorem MultiReduceTo_EvalTo :
    forall (e : Exp) (n : peano), MultiReduceTo e (ENum n) -> EvalTo e n.
Proof.
Admitted.

End Metatheorems.


(* ConvexHull.v *)

Require Import Utf8 QArith List.
Import ListNotations.

Require Import Slope_base.

Record newton_segment := mkns
  { ini_pt : (Q * Q);
    fin_pt : (Q * Q);
    oth_pts : list (Q * Q) }.

Definition slope ms := slope_expr (ini_pt ms) (fin_pt ms).

Fixpoint minimise_slope pt₁ pt₂ pts₂ :=
  match pts₂ with
  | [] =>
      {| ini_pt := pt₁; fin_pt := pt₂; oth_pts := [] |}
  | pt₃ :: pts₃ =>
      let ms := minimise_slope pt₁ pt₃ pts₃ in
      match Qcompare (slope_expr pt₁ pt₂) (slope ms) with
      | Eq =>
          {| ini_pt := pt₁; fin_pt := fin_pt ms; oth_pts := pt₂ :: oth_pts ms |}
      | Lt =>
          {| ini_pt := pt₁; fin_pt := pt₂; oth_pts := [] |}
      | Gt =>
          ms
      end
  end.

Definition lower_convex_hull_points pts :=
  match pts with
  | [] => None
  | [pt₁] => None
  | pt₁ :: pt₂ :: pts₂ =>
      let ms := minimise_slope pt₁ pt₂ pts₂ in
      Some {| ini_pt := ini_pt ms; fin_pt := fin_pt ms; oth_pts := oth_pts ms |}
  end.

Theorem minimised_slope_beg_pt : ∀ pt₁ pt₂ pts,
  ini_pt (minimise_slope pt₁ pt₂ pts) = pt₁.
Proof.
intros pt₁ pt₂ pts.
revert pt₁ pt₂.
induction pts as [| pt]; intros; [ reflexivity | simpl ].
remember (minimise_slope pt₁ pt pts) as ms.
remember (slope_expr pt₁ pt₂ ?= slope ms) as c.
symmetry in Heqc.
destruct c; simpl; [ reflexivity | reflexivity | idtac ].
subst ms; apply IHpts.
Qed.

Theorem slope_slope_expr : ∀ ms pt₁ pt₂ pts,
  minimise_slope pt₁ pt₂ pts = ms
  → slope ms == slope_expr pt₁ (fin_pt ms).
Proof.
intros ms pt₁ pt₂ pts Hms.
unfold slope.
rewrite <- Hms at 1.
rewrite minimised_slope_beg_pt.
reflexivity.
Qed.


Require Import Arith.

(* some useful bindings *)
Definition peirce                 := forall P Q:Prop, ((P->Q)->P)->P.
Definition classic                := forall P:Prop, ~~P -> P.
Definition lem                    := forall P:Prop, P \/ ~P.
Definition and_to_or              := forall P Q:Prop, ~(~P /\ ~Q) -> P \/ Q.
Definition imp_to_or              := forall P Q:Prop, (P -> Q) -> (~P \/ Q).
Definition ex_to_all              := forall (A:Type) (P: A -> Prop),
    ~(exists x:A, ~P x) -> (forall x:A, P x).

Inductive isZero : nat -> Prop :=
| IsZero : isZero 0
.

Inductive Even : nat -> Prop :=
| EvenO  : Even 0
| EvenSS : forall (n:nat), Even n -> Even (S (S n))
.

(* discriminate tactic*)
Lemma true_neq_false1 : true <> false.
Proof. intros H. discriminate. Qed.

Definition toProp (b:bool) : Prop := if b then True else False.

(* change tactic *)
Lemma true_neq_false2 : true <> false.
Proof. intros H. change (toProp  false). rewrite <- H. simpl. exact I. Qed.

(* congruence tactic *)
Lemma true_neq_false3 : true <> false.
Proof. congruence. Qed.

(* injection tactic *)
Lemma S_inj1 : forall (n m:nat), S n = S m -> n = m.
Proof. intros n m H. injection H. intros. assumption. Qed.

(* change tactic *)
Lemma S_inj2 : forall (n m:nat), S n = S m -> n = m.
Proof.
    intros n m H. change (pred (S n) = pred (S m)).
    rewrite H. reflexivity.
Qed.

(* apply tactic *)
Lemma obvious1 : True.
Proof. apply I. Qed.

(* constructor tactic *)
Lemma obvious2 : True.
Proof. constructor. Qed.

(* destruct tactic *)
Lemma False_imp1: False -> 2 + 2 = 5.
Proof. intros H. destruct H. Qed.

(* exfalso tactic *)
Lemma False_imp2: False -> 2 + 2 = 5.
Proof. intros H. exfalso. assumption. Qed.

(* discriminate tactic *)
Lemma not1 : ~(2 + 2 = 5).
Proof. intros H. discriminate H. Qed.

Fixpoint even (n:nat) : bool :=
    match n with
    | 0     => true
    | S p   => negb (even p)
    end.

(* change tactic *)
Lemma not2 : ~(2 + 2 = 5).
Proof. intros H. change (toProp (even 5)). rewrite <- H. simpl. apply I. Qed.

(* split tactic *)
Lemma and_comm1 : forall (A B:Prop), A /\ B -> B /\ A.
Proof. intros A B [H1 H2]. split; assumption. Qed.

(* left and right tactics *)
Lemma or_comm1 : forall (A B:Prop), A \/ B -> B \/ A.
Proof.
    intros A B [H1|H2].
    - right. assumption.
    - left . assumption.
Qed.

(* tauto tactic *)
Lemma and_comm2 : forall (A B:Prop), A /\ B -> B /\ A.
Proof. tauto. Qed.

(* tauto tactic *)
Lemma or_comm2 : forall (A B:Prop), A \/ B -> B \/ A.
Proof. tauto. Qed.

(* exists tactic *)
Lemma exist1 : exists (n:nat), n + 3 = 5.
Proof. exists 2. reflexivity. Qed.

(* firstorder tactic *)
Lemma firstorder1 : forall (A:Type) (P: A->Prop),
  (forall x:A, P x) -> ~(exists x:A, ~P x).
Proof.  firstorder. Qed.

(* intuition tactic *)
Lemma intuition1 : peirce -> classic.
Proof.
  unfold peirce. unfold classic. intuition.
  apply H with False. intros H1. exfalso. apply H0. assumption.
Qed.

(* firstorder tactic *)
Lemma firstorder2 : peirce -> classic.
Proof.
  unfold peirce. unfold classic. firstorder.
  apply H with False. intros H1. exfalso. apply H0. assumption.
Qed.

(* cut tactic *)
Lemma cut1: 1 + 1 = 2.
Proof.
    cut (2 + 2 = 4).
    - intros E. reflexivity.
    - reflexivity.
Qed.

(* assert tactic *)
Lemma assert1: 1 + 1 = 2.
Proof.
    assert (2 + 2 = 4) as E.
    - reflexivity.
    - reflexivity.
Qed.

(* remember tactic *)
Lemma remember1 : 1 + 1 = 2.
    remember 1 as x eqn:E.
    rewrite E. reflexivity.
Qed.

(* inversion tactic *)
Lemma not_isZero_1 : ~ isZero 1.
Proof. intros H. inversion H. Qed.

(* tactic auto *)
Hint Constructors Even.

Lemma Even_4 : Even 4.
Proof. auto. Qed.

(* tactic ring*)
Lemma fact_basic: forall (n:nat), (S n) * fact n = fact (S n).
Proof.
    induction n as [|n IH].
    - reflexivity.
    - simpl. ring.
Qed.

(* refine tactic *)
Definition refine_test : forall (n m:nat), {n = m} + {n <> m}.
    refine (fix f (n m:nat) : {n = m} + {n <> m} :=
        match n,m with
        | 0,0       => left _                             (* leaving a hole *)
        | S n, S m  => if f n m then left _ else right _  (* two more holes *)
        | _, _      => right _                            (* one last hole  *)
        end).
    (* getting 5 goals though, not four, probably a good reason to this *)
    (* could factorize with a single 'congruence'                       *)
    - reflexivity.
    - congruence.
    - congruence.
    - congruence.
    - congruence.
Defined.  (* rather than 'Qed' so proof term is not opaque  *)

(* decide tactic *)
Definition decide_test : forall (n m:nat), {n = m} + {n <> m}.
    decide equality.
Defined.

(*
Print decide_test.
*)


Require Export Lib.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Setoids.Setoid.

Parameter set : Type.

Parameter In : set → set → Prop.

Notation "x ∈ X" := (In x X) (at level 69).
Notation "x ∉ X" := (not (In x X)) (at level 69).

Definition Subq (X Y : set) : Prop := ∀ x : set, x ∈ X → x ∈ Y.

Notation "X ⊆ Y" := (Subq X Y) (at level 69).

Lemma Subq_refl : ∀ (A : set), A ⊆ A.
Proof. compute. auto. Qed.
Hint Resolve Subq_refl.

Instance Subq_Refl : Reflexive Subq.
Proof. exact Subq_refl. Qed.

Lemma Subq_trans : ∀ (A B C : set), A ⊆ B → B ⊆ C → A ⊆ C.
Proof. compute. auto. Qed.
Hint Resolve Subq_trans.

Instance Subq_Trans : Transitive Subq.
Proof. exact Subq_trans. Qed.

Definition set_equiv (A B : set) := A ⊆ B /\ B ⊆ A.

Instance set_Equiv : Equivalence set_equiv.
Proof.
  constructor.
  - intro x.
    split; intros; auto.
  - intros x y.
    destruct 1.
    split; intros; auto.
  - intros x y z.
    destruct 1, 1.
    split; intros;
    [ apply (Subq_trans x y z)
    | apply (Subq_trans z y x) ]; auto.
Qed.

Add Parametric Relation : set set_equiv
  reflexivity proved by (@Equivalence_Reflexive _ _ set_Equiv)
  symmetry proved by (@Equivalence_Symmetric _ _ set_Equiv)
  transitivity proved by (@Equivalence_Transitive _ _ set_Equiv)
  as set_equiv_rel.

(* Axiom 1 (Extensionality). Two sets X and Y are equal if they contain the
   same elements. *)

Axiom extensionality : ∀ X Y : set, X ⊆ Y → Y ⊆ X → X = Y.
Hint Resolve extensionality.

Lemma extensionality_E : ∀ X Y : set, X = Y -> X ⊆ Y ∧ Y ⊆ X.
Proof.
  intros. split; compute; intros.
    rewrite <- H. assumption.
    rewrite H. assumption.
Qed.

Hint Resolve extensionality_E.

Ltac extension := apply extensionality; unfold Subq; intros.

(* Axiom 2 (∈-induction). The membership relation on sets satisfies the
   induction principle. *)

Axiom In_ind : ∀ P : set → Prop,
  (∀ X : set, (∀ x, x ∈ X → P x) → P X) →
  (∀ X : set, P X).

(* Axiom 3 (The empty set). There ∃ a set which does not contain any
   elements.  We call this set the empty set and denote it by ∅. *)

Parameter Empty : set.

Notation "∅" := (Empty).

Axiom Empty_E : ∀ x : set, x ∉ ∅.

Hint Resolve Empty_E.

Definition inh_set (S : set) := ∃ w, w ∈ S.

(* Axiom 4 (Pairing). For all sets y and z there ∃ a set containing
   exactly y and z as elements. We call this set the unordered pair of y and z
   and denote it by {y,z}. *)

Parameter UPair : set → set → set.

Axiom UPair_I1 : ∀ y z : set, y ∈ (UPair y z).
Axiom UPair_I2 : ∀ y z : set, z ∈ (UPair y z).
Axiom UPair_E : ∀ x y z : set, x ∈ (UPair y z) → x = y ∨ x = z.

Hint Resolve UPair_I1.
Hint Resolve UPair_I2.
Hint Resolve UPair_E.

Notation "{ a , b }" := (UPair a b) (at level 69).

(* The axiomatic pairing of sets a and b is agnostic with respect to their
   ordering. *)

Theorem pair_agnostic : ∀ a b, {a, b} = {b, a}.
Proof.
  intros.
  apply (extensionality (UPair a b) (UPair b a));
  intros x H; apply UPair_E in H; inversion H; rewrite H0; auto.
Qed.

Hint Resolve pair_agnostic.

Ltac pair_e H := apply UPair_E in H; try (inv H); try auto.
Ltac pair_1 := apply UPair_I1; try auto.
Ltac pair_2 := apply UPair_I2; try auto.

(* Axiom 5 (Union). Given a collection of sets X, there ∃ a set whose
   elements are exactly those which are a member of at least one of the sets
   in the collection X.  We call this set the union over X and denote it by
   ∪. *)

Parameter Union : set → set.

Axiom Union_I : ∀ X x Y : set, x ∈ Y → Y ∈ X → x ∈ (Union X).
Axiom Union_E : ∀ X x : set, x ∈ (Union X) → ∃ Y : set, x ∈ Y ∧ Y ∈ X.

Hint Resolve Union_I.
Hint Resolve Union_E.

Definition BinUnion (A B : set) : set := Union (UPair A B).

Ltac obvious_PU :=
  intros; repeat (match goal with
  | [ |- ?X = ?Y ] => extension

  | [ |- ?A ∈ ({?A, ?B}) ] => pair_1
  | [ |- ?B ∈ ({?A, ?B}) ] => pair_2
  | [ H : ?X ∈ ({?A, ?B}) |- _ ] => pair_e H

  | [ H : ?X ∈ Union ?M |- _ ] =>
    apply Union_E in H; destruct H; inv H

  | [ H : ?X ∈ ?A |- ?X ∈ Union({?A, ?B}) ] =>
    apply Union_I with (Y := A)
  | [ H : ?X ∈ ?B |- ?X ∈ Union({?A, ?B}) ] =>
    apply Union_I with (Y := B)

  end; auto).

Lemma BinUnion_I1 : ∀ A B a: set, a ∈ A → a ∈ BinUnion A B.
Proof. compute. obvious_PU. Qed.

Hint Resolve BinUnion_I1.

Lemma BinUnion_I2 : ∀ A B b: set, b ∈ B → b ∈ BinUnion A B.
Proof. compute. obvious_PU. Qed.

Hint Resolve BinUnion_I2.

Lemma BinUnion_E : ∀ A B x, x ∈ BinUnion A B → x ∈ A ∨ x ∈ B.
Proof. compute. obvious_PU. Qed.

Hint Resolve BinUnion_E.

Notation "X ∪ Y" := (BinUnion X Y) (at level 69).

Ltac union_e H := apply BinUnion_E in H; destruct H; try (inv H); try auto.
Ltac union_1 := apply BinUnion_I1; try auto.
Ltac union_2 := apply BinUnion_I2; try auto.

(* Axiom 6 (Powerset). Given a set X, there ∃ a set which contains as its
   elements exactly those sets which are the subsets of X. We call this set the
   powerset of X and denote it by 𝒫(X). *)

Parameter Power : set → set.

Axiom Power_I : ∀ X Y : set, Y ⊆ X → Y ∈ (Power X).
Axiom Power_E : ∀ X Y : set, Y ∈ (Power X) → Y ⊆ X.

Hint Resolve Power_I.
Hint Resolve Power_E.

(* Axiom 7 (Replacement). Given a unary set former F and a set X, there ∃
   a set which contains exactly those elements obtained by applying F to each
   element in X. We denote this construction with {F x | x ∈ X}. *)

Parameter Repl : (set → set) → set → set.

Axiom Repl_I : ∀ (X : set) (F : set → set) (x : set),
  x ∈ X → (F x) ∈ (Repl F X).
Axiom Repl_E : ∀ (X : set) (F : set → set) (y : set),
  y ∈ (Repl F X) → ∃ x : set, x ∈ X ∧ y = F x.

Hint Resolve Repl_I.
Hint Resolve Repl_E.

Ltac obvious_BUR :=
  repeat (try obvious_PU; match goal with
  | [ H : ?X ∈ (?A ∪ ?B) |- _ ] => union_e H
  | [ |- ?A ∈ (?A ∪ ?B) ] => union_1
  | [ |- ?B ∈ (?A ∪ ?B) ] => union_2
  end; auto).


(* ================================================================== *)
Section EX.

Variables (A:Set) (P : A->Prop).
Variable Q:Prop.

(* Check the type of an expression. *)
Check P.
Check Set.
Check A -> Prop.

Variable a:A.

Check P a.

Lemma trivial : forall x:A, P x -> P x.
Proof.
  intros.
  assumption.
Qed.

(* Prints the definition of an identifier. *)
Print trivial.

Lemma example : forall x:A, (Q -> Q -> P x) -> Q -> P x.
Proof.
  intros x H H0.
  apply H.
  assumption.
  assumption.
Qed.

Print example.

Proposition nova : Q -> ~ ~ Q.
Proof.
  intros.
  unfold not.
  intros.
  apply H0.
  assumption.
Qed.           (* when we close the proof the definition of the identifier
                  "nova" goes to the global environment *)

Theorem demo : forall y,  Q -> (~ ~ Q -> P y) -> P y.
Proof.
  intros.
  apply H0.
  apply nova.   (* we can use a definition in the global environment *)
  assumption.
Qed.

End EX.

Print trivial.
Print example.
(* ================================================================== *)

(* ================================================================== *)
(* ====================== Propositional Logic ======================= *)
(* ================================================================== *)

Section ExamplesPL.

Variables Q P :Prop.

Lemma ex1 : (P -> Q) -> ~Q -> ~P.
Proof.
  tauto.
Qed.

Print ex1.

Lemma ex1' : (P -> Q) -> ~Q -> ~P.
Proof.
  intros.
  intro.
  apply H0.
  apply H.
  assumption.
Qed.

Print ex1'.

Lemma ex2 : P /\ Q -> Q /\ P.
Proof.
  intro H.
  split.
  destruct H as [H1 H2].
  exact H2.
  destruct H; assumption.
Qed.

(* We can itemize the subgoals using - for each of them. Note that whem entering in this mode the other subgoals are not displayed. For nested item use the symbols -, +, *, --, ++, **, ... *)
Lemma ex2' : P /\ Q -> Q /\ P.
Proof.
  intro H.  split.
  - destruct H as [H1 H2]. exact H2.
  - destruct H; assumption.
Qed.

Lemma ex3 : P \/ Q -> Q \/ P.
Proof.
  intros.
  destruct H as [h1 | h2].
  - right. assumption.
  - left; assumption.
Qed.

Theorem ex4 : forall A:Prop, A -> ~~A.
Proof.
  intros.
  intro.
  apply H0.
  exact H.
Qed.

Lemma ex4' : forall A:Prop, A -> ~~A.
Proof.
  intros.
  red.     (* does only the unfolding of the head of the goal *)
  intro.
  unfold not in H0.   (* unfold – applies the delta rule for a transparent constant. *)
  apply H0; assumption.   (* exact (H0 H) *)
Qed.

Axiom double_neg_law : forall A:Prop, ~~A -> A.  (* classical *)

(* CAUTION: Axiom is a global declaration.
   Even after the section is closed double_neg_law is assume in the enviroment, and can be used.
   If we want to avoid this we should decalre double_neg_law using the command Hypothesis.
*)

Lemma ex5 : (~Q -> ~P) -> P -> Q.   (* this result is only valid classically *)
Proof.
  intros.
  apply double_neg_law.
  intro.
  (* apply H; assumption. *)
  apply H.
  - assumption.
  - assumption.
Qed.

Lemma ex6 : (P\/Q)/\~P -> Q.
Proof.
  intros.
  elim H. intros .
  destruct H0.
  - contradiction.
  - assumption.
Qed.

Lemma ex7 : ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
  red.
  split.
  - intros.
    split.
    + unfold not in H.
      intro H1.
      apply H.
      left; assumption.
    + intro H1; apply H; right; assumption.
  - intros H H1.
    destruct H.
    destruct H1.
    + contradiction.
    + contradiction.
Qed.

Lemma ex7' : ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
  tauto.
Qed.

Variable B :Prop.
Variable C :Prop.

(* exercise *)
Lemma ex8 : (P->Q) /\ (B->C) /\ P /\ B -> Q/\C.
Admitted.

(* exercise *)
Lemma ex9 : ~ (P /\ ~P).
Admitted.

End ExamplesPL.

(* ================================================================== *)
(* =======================  First-Order Logic ======================= *)
(* ================================================================== *)

Section ExamplesFOL.

Variable X :Set.
Variable t :X.
Variables R W : X -> Prop.

Lemma ex10 : R(t) -> (forall x, R(x)->~W(x)) -> ~W(t).
Proof.
  intros.
  apply H0.
  exact H.
Qed.

Lemma ex11 : forall x, R x -> exists x, R x.
Proof.
  intros.
  exists x.
  assumption.
Qed.

Lemma ex11' : forall x, R x -> exists x, R x.
Proof.
  firstorder.
Qed.

Lemma ex12 : (exists x, ~(R x)) -> ~ (forall x, R x).
Proof.
  intros H H1.
  destruct H as [x0 H0].
  apply H0.
  apply H1.
Qed.

(* Exercise *)
Lemma ex13 : (forall x, R x) \/ (forall x, W x) -> forall x, (R x) \/ (W x).
Admitted.

Variable G : X->X->Prop.

(* Exercise *)
Lemma ex14 : (exists x, exists y, (G x y)) -> exists y, exists x, (G x y).
Admitted.

(* Exercise *)
Proposition ex15: (forall x, W x)/\(forall x, R x) -> (forall x, W x /\ R x).
Admitted.

(* ------- Note that we can have nested sections ----------- *)
Section Relations.

Variable D : Set.
Variable Rel : D->D->Prop.

Hypothesis R_symmetric : forall x y:D, Rel x y -> Rel y x.
Hypothesis R_transitive : forall x y z:D, Rel x y -> Rel y z -> Rel x z.

Lemma refl_if : forall x:D, (exists y, Rel x y) -> Rel x x.
Proof.
  intros.
  destruct H.
  (* try "apply R_transitive" to see de error message *)
  apply R_transitive with x0.
  - assumption.
  - apply R_symmetric.
    assumption.
Qed.

Check refl_if.

End Relations.

Check refl_if. (* Note the difference after the end of the section Relations. *)

(* ====== OTHER USES OF AXIOMS ====== *)

(* --- A stack abstract data type --- *)
Section Stack.

Variable U:Type.

Parameter stack : Type -> Type.
Parameter emptyS : stack U.
Parameter push : U -> stack U -> stack U.
Parameter pop : stack U -> stack U.
Parameter top : stack U -> U.
Parameter isEmpty : stack U -> Prop.

Axiom emptyS_isEmpty : isEmpty emptyS.
Axiom push_notEmpty : forall x s, ~isEmpty (push x s).
Axiom pop_push : forall x s, pop (push x s) = s.
Axiom top_push : forall x s, top (push x s) = x.

End Stack.

Check pop_push.

(* Now we can make use of stacks in our formalisation!!! *)

(* A NOTE OF CAUTION!!! *)
(* The capability to extend the underlying theory with arbitary axiom
   is a powerful but dangerous mechanism. We must avoid inconsistency.
*)
Section Caution.

Check False_ind.

Hypothesis ABSURD : False.

Theorem oops : forall (P:Prop), P /\ ~P.
elim ABSURD.
Qed.

End Caution. (* We have declared ABSURD as an hypothesis to avoid its use outside this section. *)


Fixpoint max (n m : nat) {struct n} : nat :=
  match n, m with
  | 0 , _ => m
  | S n' , 0 => n
  | S n' , S m' => S (max n' m')
  end.

Example max_test1 : max 100 200 = 200. simpl. reflexivity. Qed.
Example max_test2 : max 3 3 = 3. simpl. reflexivity. Qed.
Example max_test3 : max 4 3 = 4. simpl. reflexivity. Qed.

Inductive Tree : Type :=
  | Leaf : Tree
  | Node2 : Tree -> Tree -> Tree
  | Node3 : Tree -> Tree -> Tree -> Tree.

Definition exTree1 : Tree := Node2 (Node3 Leaf Leaf Leaf) Leaf.

Definition exTree2 : Tree := Node2 (Node2 Leaf (Node2 (Node2 Leaf Leaf) Leaf)) (Node2 Leaf Leaf).

Fixpoint height (t : Tree) {struct t} : nat :=
  match t with
  | Leaf => 0
  | Node2 lhs rhs => S (max (height lhs) (height rhs))
  | Node3 lhs mid rhs => S (max (max (height lhs) (height mid)) (height rhs))
  end.

(* BEGIN FIX *)
Example height_test_1 : height exTree1 = 2.
Proof.
  trivial.
Qed.
(* END FIX *)

(* BEGIN FIX *)
Example height_test_2 : height exTree2 = 4.
Proof.
  trivial.
Qed.
(* END FIX *)

(* BEGIN FIX *)
Lemma max_0 (m : nat) : max m 0 = m.
Proof.
  induction m.
    trivial.
    simpl. trivial.
Qed.
(* END FIX *)

(* BEGIN FIX *)
Lemma height_Leaf (t : Tree) : height (Node2 t Leaf) = height (Node2 Leaf t).
Proof.
  simpl. rewrite max_0. trivial.
Qed.
(* END FIX *)

(* BEGIN FIX *)
Lemma max_comm : forall (m n : nat),  max m n = max n m.
Proof.
  intro m.
  induction m.
    simpl. intro n. rewrite max_0. trivial.
    (* why do I get a more general IH? *)
    destruct n.
      trivial.
      simpl. rewrite IHm. trivial.
Qed.
(* END FIX *)


(* Software Foundations *)
(* Exercice 2 stars, fold_length *)

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

Fixpoint fold{X Y: Type}(f: X -> Y -> Y)(l: list X)(v: Y): Y :=
    match l with
    |[]   => v
    |h::t => f h (fold f t v)
    end.

Definition fold_length{X: Type}(l: list X): nat :=
      fold (fun _ n => S n) l O.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct: forall X (l: list X),
      fold_length l = length l.
Proof.
    intros. unfold fold_length.
    induction l as [|h t].
    simpl. reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.


(**
The Little Prover の memb?/remb をCoqで解いてみる（サブリスト改訂版）
 *)

Require Import Bool.
Require Import List.
Require Import Program.
Set Implicit Arguments.

(** * はじめに *)

(**
The Little Prover (TLP) の第6章では、memb?/remb という定理が扱われています。
これは、リニアなリストの要素から、文字 '?' を削除する関数 remb と、
これは、リニアなリストの要素に、文字 '?' が含まれるかを判定する関数 memb? が
定義されているとき、
任意のリスト xs に対して、(memb? (remb xs)) が必ず False になるというものです。

オリジナルはLisp系の言語なので、リストの要素は任意のデータでよいのですが、
Coqの場合は、自然数のリストとし、もじ '?' の代わりに 0 とします。
  *)

(**
ソースコードは、
#<a href="https://github.com/suharahiromichi/coq/blob/master/prog/coq_membp_remb_3.v">
ここ
</a>
にあります。
 *)

(**
まず、membp (memb? に対応する) の自然数のリストに 0 が含まれていることを判定する関数を定義ましす。
リストの先頭から見ていき 0 が含まれていたらそこで True を返します。
*)

Fixpoint membp (xs : list nat) : Prop :=
  match xs with
  | nil => False
  | 0 :: xs' => True
  | _ :: xs' => membp xs'
  end.

Compute membp (1 :: 0 :: 2 :: nil).         (** ==> [True] *)

Compute membp (1 :: 2 :: 3 :: nil).         (** ==> [False] *)

Compute membp nil.                          (** ==> [False] *)

(**
ついで、remb のリストから 0 を削除する関数を定義します。
リストの先頭から見ていき 0 なら、それを含まない結果を返し
false なら、それを含む結果を返します。
*)

Fixpoint remb (xs : list nat) : list nat :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb xs'
  | x :: xs' => x :: remb xs'
  end.

Compute remb (0 :: 1 :: 0 :: nil).         (** ==> [[1]] *)

(** * memb?/remb の証明 *)

(**
memb?/remb に対応する membp_remb は、文字通りの定義です。
結果は偽であるため、「~」がついています。
 *)

Definition membp_remb (xs : list nat) := ~ membp (remb xs).

(** 以下に、membp_remb を証明します。線形リスト xs に対する帰納法と、
要素 x に対する場合分けだけで証明されています。
なお、帰納法の仮定IHxsは、ふたつめとみっつめのnowでトリビアルに使われます。
 *)

Lemma le_membp_remb : forall (xs : list nat), membp_remb xs.
Proof.
  unfold membp_remb.
  induction xs as [|x xs IHxs].
  - now simpl.
  (** x が 0 か 0 でないかで場合分けする。 *)
  - case x as [| x']; simpl.
    (** ここで帰納法の仮定を使う。 *)
    + now trivial.
    + now trivial.

  Restart.
  unfold membp_remb.
  intros xs.
  induction xs as [|x xs IHxs]; try auto.
  now case x.
Qed.

(**
memb?/remb は定理としては自明ですが、 0 が含まれないことをチェックする関数membpによって、
 0 を削除する関数rembが正しく動作していることを証明する、と考えることができます。

これは、関数の定義とその証明を同時におこなう証明駆動開発の一例となります。
Coqにはそれをサポートする「Program」コマンドがあります。
これを使って remb を再定義してみましょう。

remb' の値は、単なる list nat ではなく、
[{ys : list nat | ~ membp ys}]
すなわち、
[~ membp ys] を満たす [ys] の集合の要素、
となります。

これだと、最初に想定した型と違うので困ると思うかもしれませんが、
「Program」コマンドの中では、そのサブタイプ・コアーションの機能によって、
list boot 型と同一視されます。

remb' の結果が普通にconsされていることに気づいてください。

「Program」コマンドの中では、そのサブタイプ・コアーションは、
再帰呼び出しのみならず、他の（定義済みの）任意な関数に適用されます。
 *)

Program Fixpoint remb' (xs : list nat) : {ys : list nat | ~ membp ys} :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb' xs'
  | x :: xs' => x :: remb' xs'
  end.
Obligation 2.
Proof.
  case x as [| x']; simpl.
  - generalize (H xs'); intro H'.
    exfalso.
    now apply H'.
  - now trivial.
Defined.

Compute ` (remb' (0 :: 1 :: 0 :: nil)).     (** ==> [[1]] *)

Extraction remb'.
(**
生成されたコードには、rembp は含まれていない。

[[
val remb' : nat list -> nat list,

let rec remb' = function
| Nil -> Nil
| Cons (x, xs') ->
  (match x with
   | O -> remb' xs'
   | S n -> let x0 = S n in Cons (x0, (remb' xs')))
]]
*)

(** * 証明駆動開発 *)

(** ** remb 条件を Inductive に定義する *)

(** remb を Inductive に定義した、Listwo0 (List without 0 のつもり) を定義します。 *)

Inductive Listwo0 : list nat -> Prop :=
| Wo0_nil      : Listwo0 nil
| Wo0_skip   l : Listwo0 l -> Listwo0 (0 :: l)
| Wo0_cons x l : x <> 0 -> Listwo0 l -> Listwo0 (x :: l).

Hint Constructors Listwo0.

Program Fixpoint remb'' (xs : list nat) : {ys : list nat | Listwo0 ys} :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb'' xs'
  | x :: xs' => x :: remb'' xs'
  end.
Obligation 2.
Proof.
  apply Wo0_cons.
  - case x as [| x']; simpl.
    + generalize (H xs'); intro H'.
      exfalso.
      now apply H'.
    + now trivial.
  - now trivial.
Defined.

Compute ` (remb'' (0 :: 1 :: 0 :: nil)).    (** ==> [[1]] *)

(**
remb' の定義を「リストから 0 を除去する関数」の証明付き定義と考えると問題があります。
 *)

(** 0を抜いたサブリストの関係を定義します。  *)

Inductive Sublist0 : list nat -> list nat -> Prop :=
| SL0_nil         : Sublist0 nil nil
| SL0_skip   l' l : Sublist0 l' l -> Sublist0 l' (0 :: l)
| SL0_cons x l' l : x <> 0 -> Sublist0 l' l -> Sublist0 (x :: l') (x :: l).

Hint Constructors Sublist0.

Program Fixpoint remb''' (xs : list nat) :
  {ys : list nat | Sublist0 ys xs} :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb''' xs'
  | x :: xs' => x :: remb''' xs'
  end.
Obligation 3.
Proof.
  apply SL0_cons.
  - case x as [| x']; simpl.
    + generalize (H xs'); intro H'.
      exfalso.
      now apply H'.
    + now trivial.
  - now trivial.
Defined.

Compute ` (remb''' (0 :: 1 :: 0 :: nil)).    (** ==> [[1]] *)

Extraction remb'''.

(**
生成されたコードには、Sublist0 は含まれていません。

[[
val remb'' : nat list -> nat list

let rec remb'' = function
| Nil -> Nil
| Cons (b, xs') ->
  (match b with
   |  0  -> remb'' xs'
   | False -> Cons (False, (remb'' xs')))
]]
 *)

(** * 帰納法の公理 *)

(**
TLPにもどって、帰納法による証明について考えてみましょう。
TLPでは、（例によって、天から降ってきた）「inductive claim」を証明しています。
これの導きかたは第6章の最後に記載されていますが、Coqの場合は、
リストの型定義にもとづく「公理」を使います。
 *)

Check list_ind : forall (A : Type) (P : list A -> Prop),
    P [] ->
    (forall (a : A) (l : list A), P l -> P (a :: l)) ->
    forall l : list A, P l.

(**
これを membp_remb に適用すると次を得ます。
繰り返しますが、これは証明するべきものではなく、「公理」です。
 *)

Check list_ind membp_remb :
  membp_remb [] ->
  (forall (a : nat) (l : list nat), membp_remb l -> membp_remb (a :: l)) ->
  forall l : list nat, membp_remb l.

(**
この公理を使うなら、

[forall l : list nat, membp_remb l]

を証明するには、

[membp_remb []]

と

[forall (a : nat) (l : list nat), membp_remb l -> membp_remb (a :: l)]

とを証明すればよいことになります。後者は、TLPでは、l は nil でないことを条件に、
[(cdr l)] をとっていて、つまり、

[forall (l : list nat  ), membp_remb (tl l) -> membp_remb l]

となっています。おなじですね。
 *)

(**
実際の証明は、以下の通りです。
 *)

Goal forall xs, membp_remb xs.
Proof.
  intros xs.
  apply (list_ind membp_remb).
  - now simpl.
  - intros x' xs' IHxs.
    case x'; simpl.
    + now trivial.
    + now trivial.
Qed.

(**
最初の証明では、

[induction xs] というタクティクを使いましたが、

この公理を

[apply (list_ind membp_remb)]

として、適用することと同じです。
 *)

(* END *)


Require Import Coq.Logic.Classical.
Require Import Coq.Sets.Ensembles.

Lemma union_empty_r : forall U A,
  Union U A (Empty_set U) = A.
Proof.
  intros. apply Extensionality_Ensembles.
  split; intros x x_in_one.
  inversion x_in_one as [ _x in_A x_eq | _x false x_eq ].
  auto. inversion false.
  left. auto.
Qed.

Lemma union_empty_l : forall U A, Union U (Empty_set U) A = A.
Proof.
  intros. apply Extensionality_Ensembles. split; intros x x'.
  inversion x'. inversion H. auto. apply Union_intror. auto.
Qed.

Lemma union_swap : forall U A B,
  Union U A B = Union U B A.

intros.
apply Extensionality_Ensembles.
split; intros x x_in_one;
destruct x_in_one as [ x x_in_left | x x_in_right ];
auto using Union_introl, Union_intror.

Qed.

Lemma disjoint_setminus :
  forall U A B,
    Disjoint U A (Setminus U B A).

  intros.
  apply Disjoint_intro. unfold not.
  intros x in_int.
  destruct in_int as [ x x_in_A x_in_setminus ].
  destruct x_in_setminus.
  tauto.

Qed.

Lemma add_add_to_union_couple :
  forall U A x y,
    (Add U (Add U A x) y) = (Union U A (Couple U y x)).

intros.
apply Extensionality_Ensembles. split; intros z z_in_one.
destruct z_in_one as [ z' [ z z_in_A | z z_is_x ] | z z_is_y ].
left. auto.
right. inversion z_is_x. subst z. right.
right. inversion z_is_y. subst z. left.
destruct z_in_one as [ z z_in_A | z [ | ] ].
left. left. auto.
right. apply In_singleton.
left. right. apply In_singleton.

Qed.

Lemma couple_swap :
  forall U A B,
    Couple U A B = Couple U B A.

intros.
apply Extensionality_Ensembles. split; intros x x_in_one.
destruct x_in_one. right. left.
destruct x_in_one. right. left.

Qed.

Lemma add_subtract :
  forall U A x,
    In U A x ->
    A = Add U (Subtract U A x) x.

intros.
apply Extensionality_Ensembles. split; intros y y_in_one.
assert (x = y \/ x <> y) as [ is_x | not_x ]. apply classic.
right. subst y. apply In_singleton.
left. split. auto. intros false.
inversion false. tauto.
destruct y_in_one as [ y y_in_subtract | y y_is_x ].
destruct y_in_subtract. auto. inversion y_is_x. subst y. auto.

Qed.

Theorem eqImpliesSameSet : forall (T:Type) T1 T2, T1 = T2 -> Same_set T T1 T2.
Proof.
  intros. unfold Same_set. unfold Included. split; intros.
  {subst. assumption. }
  {subst. assumption. }
Qed.

Hint Unfold In.
Hint Constructors Singleton Couple.

Theorem SingleEqCouple : forall (T:Type) s1 s2 s3,
                           Singleton T s1 = Couple T s2 s3 -> s1 = s2 /\ s1 = s3.
Proof.
  intros. apply eqImpliesSameSet in H. unfold Same_set in H.
  unfold Included in H. inversion H. split.
  {assert(In T (Couple T s2 s3) s2). auto. apply H1 in H2.
   inversion H2. reflexivity. }
  {assert(In T (Couple T s2 s3) s3). auto. apply H1 in H2.
   inversion H2. reflexivity. }
Qed.

Theorem SingletonEq : forall (T:Type) (e1 e2 : T), Singleton T e1 = Singleton T e2 -> e1 = e2.
Proof.
  intros. apply eqImpliesSameSet in H. unfold Same_set in H. unfold Included in *.
  inversion H. assert(Ensembles.In T (Singleton T e1) e1). auto. apply H0 in H2.
  inversion H2. reflexivity. Qed.

Theorem UnionEqSingleton : forall (T:Type) S e1 e2,
                             Union T S (Singleton T e1) = Singleton T e2 ->
                             e1 = e2.
Proof.
  intros. apply eqImpliesSameSet in H. unfold Same_set in H. unfold Included in *.
  inversion H. assert(In T (Union T S(Singleton T e1)) e1).
  apply Union_intror. constructor. apply H0 in H2. inversion H2.
  reflexivity. Qed.

Theorem InL : forall X T1 T2 t, In X T2 t -> In X (Union X T1 T2) t.
Proof.
  intros. apply Union_intror. auto.
Qed.

Hint Resolve InL.

Ltac solveSet := try(solve[eauto with sets]); try solve[eapply InL; eauto with sets].

Ltac eqSets := apply Extensionality_Ensembles; unfold Same_set; unfold Included; split; intros.

Theorem disjointUnionEqSingleton : forall (T:Type) S e1 e2,
                                     Disjoint T S (Singleton T e1) ->
                                     Union T S (Singleton T e1) = Singleton T e2 ->
                                     e1 = e2 /\ S = Empty_set T.
Proof.
  intros. apply eqImpliesSameSet in H0. unfold Same_set in *. unfold Included in *.
  inversion H0. inversion H. split.
  {assert(In T (Union T S (Singleton T e1)) e1). apply Union_intror.
   constructor. apply H1 in H4. inversion H4. reflexivity. }
  {assert(In T (Singleton T e2) e2). constructor. apply H2 in H4. inversion H4.
   {assert(In T (Union T S (Singleton T e1)) e1). solveSet. apply H1 in H7.
    inversion H7. subst. inversion H.
    assert(In T (Intersection T S (Singleton T e1)) e1). solveSet.
    apply H6 in H8. contradiction. }
   {subst. apply Extensionality_Ensembles. unfold Same_set. unfold Included.
    split; intros.
    {assert(In T (Union T S (Singleton T e1)) x). solveSet.
     apply H1 in H7. inversion H7. subst. inversion H5. subst.
     assert(In T (Intersection T S(Singleton T x)) x). solveSet.
     apply H3 in H8. contradiction. }
    {inversion H6. }
   }
  }
Qed.

Theorem AddEqCouple : forall T S e e1 e2, Add T S e = Couple T e1 e2 ->
                                          e = e1 \/ e = e2.
Proof.
  intros. unfold Add in H. apply eqImpliesSameSet in H. unfold Same_set in *.
  unfold Included in *. inversion H.
  assert(Ensembles.In T (Union T S (Singleton T e)) e). solveSet.
  apply H0 in H2. inversion H2; auto.
Qed.

Theorem AddEqSingleton : forall T S e e', Add T S e = Singleton T e' -> e = e'.
Proof.
  intros. unfold Add in H. apply UnionEqSingleton in H. assumption. Qed.

Theorem pullOut : forall X T t, Ensembles.In X T t -> T = Union X (Subtract X T t) (Singleton X t).
Proof.
  intros. apply Extensionality_Ensembles. unfold Same_set. unfold Included. split; intros.
  {unfold Subtract. assert(x=t \/ x<>t). apply classic. inversion H1; subst.
   {apply Union_intror. constructor. }
   {apply Union_introl. constructor. assumption. intros c. inversion c. symmetry in H3.
    contradiction. }
  }
  {inversion H0; subst.
   {inversion H1; subst. assumption. }
   {inversion H1; subst. assumption. }
  }
Qed.

Theorem SingletonNeqEmpty : forall X t, Singleton X t = Empty_set X -> False.
Proof.
  intros. apply eqImpliesSameSet in H. unfold Same_set in H. unfold Included in H. inversion H.
  assert(Ensembles.In X (Singleton X t) t). constructor. subst. apply H0 in H2. inversion H2. Qed.

Theorem AddNeqEmpty : forall X T t, Add X T t = Empty_set X -> False.
Proof.
  intros. apply eqImpliesSameSet in H. unfold Same_set in H. unfold Included in H. inversion H.
  assert(Ensembles.In X (Add X T t) t). apply Union_intror. constructor. apply H0 in H2. inversion H2.
Qed.

Theorem CoupleNeqEmpty : forall X t1 t2, Couple X t1 t2 = Empty_set X -> False.
Proof.
  intros. apply eqImpliesSameSet in H. unfold Same_set in H. unfold Included in H. inversion H.
  assert(Ensembles.In X (Couple X t1 t2) t1). constructor. apply H0 in H2. inversion H2. Qed.

Hint Constructors Union Couple.

Theorem coupleUnion : forall X t1 t2, Couple X t1 t2 = Union X (Singleton X t1) (Singleton X t2).
Proof.
  intros. apply Extensionality_Ensembles. unfold Same_set. unfold Included. split; intros.
  {inversion H; subst; auto. }
  {inversion H; subst. inversion H0; subst; auto. inversion H0; subst; auto. }
Qed.

Theorem UnionSwap : forall X T1 T2 T3,
                      Union X (Union X T1 T2) T3 = Union X (Union X T1 T3) T2.
Proof.
  intros. apply Extensionality_Ensembles. unfold Same_set. unfold Included. split; intros.
  {inversion  H; subst. inversion H0; subst. constructor. constructor. auto. apply Union_intror.
  auto. constructor. apply Union_intror. auto. }
  {inversion H; subst. inversion H0; subst. constructor. constructor. auto.
   apply Union_intror. auto. constructor. apply Union_intror. auto. }
Qed.

Theorem UnionSwapR : forall X T t1 t2 t3,
                       Union X (Union X T (Singleton X t1)) (Couple X t2 t3) =
                       Union X (Union X T (Singleton X t3)) (Couple X t2 t1).
Proof.
  intros. eqSets.
  {inversion H; inversion H0; subst; solveSet. inversion H2; subst; solveSet. }
  {inversion H; inversion H0; solveSet. inversion H2; subst. solveSet. }
Qed.

Theorem UnionSwapL : forall X T t1 t2 t3,
                       Union X (Union X T (Singleton X t1)) (Couple X t2 t3) =
                       Union X (Union X T (Singleton X t2)) (Couple X t1 t3).
Proof.
  intros. eqSets.
  {inversion H; inversion H0; solveSet. inversion H2; solveSet. }
  {inversion H; inversion H0; solveSet. inversion H2; solveSet. }
Qed.

Theorem pullOutR : forall X T t1 t2,
                     Union X T (Couple X t1 t2) =
                     Union X (Union X T (Singleton X t1)) (Singleton X t2).
Proof.
  intros. eqSets.
  {inversion H; solveSet. inversion H0; solveSet. }
  {inversion H; solveSet; inversion H0; solveSet. inversion H2; solveSet. }
Qed.

Theorem pullOutL : forall X T t1 t2,
                     Union X T (Couple X t1 t2) =
                     Union X (Union X T (Singleton X t2)) (Singleton X t1).
Proof.
  intros. eqSets.
  {inversion H; solveSet. inversion H0; solveSet. }
  {inversion H; solveSet; inversion H0; solveSet. inversion H2; solveSet. }
Qed.


(*** Montgomery Multiplication *)
(** This file implements the proofs for Montgomery Form, Montgomery
    Reduction, and Montgomery Multiplication on [Z].  We follow
    Wikipedia. *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia Coq.Structures.Equalities.
Require Import Crypto.Arithmetic.MontgomeryReduction.Definition.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SimplifyRepeatedIfs.
Require Import Crypto.Util.Notations.

Declare Module Nop : Nop.
Module Import ImportEquivModuloInstances := Z.EquivModuloInstances Nop.

Local Existing Instance eq_Reflexive. (* speed up setoid_rewrite as per https://coq.inria.fr/bugs/show_bug.cgi?id=4978 *)

Local Open Scope Z_scope.

Section montgomery.
  Context (N : Z)
          (N_reasonable : N <> 0)
          (R : Z)
          (R_good : Z.gcd N R = 1).
  Local Notation "x ≡ y" := (Z.equiv_modulo N x y) : type_scope.
  Local Notation "x ≡ᵣ y" := (Z.equiv_modulo R x y) : type_scope.
  Context (R' : Z)
          (R'_good : R * R' ≡ 1).

  Lemma R'_good' : R' * R ≡ 1.
  Proof using R'_good. rewrite <- R'_good; apply f_equal2; lia. Qed.

  Local Notation to_montgomery_naive := (to_montgomery_naive R) (only parsing).
  Local Notation from_montgomery_naive := (from_montgomery_naive R') (only parsing).

  Lemma to_from_montgomery_naive x : to_montgomery_naive (from_montgomery_naive x) ≡ x.
  Proof using R'_good.
    unfold to_montgomery_naive, from_montgomery_naive.
    rewrite <- Z.mul_assoc, R'_good'.
    autorewrite with zsimplify; reflexivity.
  Qed.
  Lemma from_to_montgomery_naive x : from_montgomery_naive (to_montgomery_naive x) ≡ x.
  Proof using R'_good.
    unfold to_montgomery_naive, from_montgomery_naive.
    rewrite <- Z.mul_assoc, R'_good.
    autorewrite with zsimplify; reflexivity.
  Qed.

  (** * Modular arithmetic and Montgomery form *)
  Section general.
    Local Infix "+" := add : montgomery_scope.
    Local Infix "-" := sub : montgomery_scope.
    Local Infix "*" := (mul_naive R') : montgomery_scope.

    Lemma add_correct_naive x y : from_montgomery_naive (x + y) = from_montgomery_naive x + from_montgomery_naive y.
    Proof using Type. unfold from_montgomery_naive, add; lia. Qed.
    Lemma add_correct_naive_to x y : to_montgomery_naive (x + y) = (to_montgomery_naive x + to_montgomery_naive y)%montgomery.
    Proof using Type. unfold to_montgomery_naive, add; autorewrite with push_Zmul; reflexivity. Qed.
    Lemma sub_correct_naive x y : from_montgomery_naive (x - y) = from_montgomery_naive x - from_montgomery_naive y.
    Proof using Type. unfold from_montgomery_naive, sub; lia. Qed.
    Lemma sub_correct_naive_to x y : to_montgomery_naive (x - y) = (to_montgomery_naive x - to_montgomery_naive y)%montgomery.
    Proof using Type. unfold to_montgomery_naive, sub; autorewrite with push_Zmul; reflexivity. Qed.

    Theorem mul_correct_naive x y : from_montgomery_naive (x * y) = from_montgomery_naive x * from_montgomery_naive y.
    Proof using Type. unfold from_montgomery_naive, mul_naive; lia. Qed.
    Theorem mul_correct_naive_to x y : to_montgomery_naive (x * y) ≡ (to_montgomery_naive x * to_montgomery_naive y)%montgomery.
    Proof using R'_good.
      unfold to_montgomery_naive, mul_naive.
      rewrite <- !Z.mul_assoc, R'_good.
      autorewrite with zsimplify; apply (f_equal2 Z.modulo); lia.
    Qed.
  End general.

  (** * The REDC algorithm *)
  Section redc.
    Context (N' : Z)
            (N'_in_range : 0 <= N' < R)
            (N'_good : N * N' ≡ᵣ -1).

    Lemma N'_good' : N' * N ≡ᵣ -1.
    Proof using N'_good. rewrite <- N'_good; apply f_equal2; lia. Qed.

    Lemma N'_good'_alt x : (((x mod R) * (N' mod R)) mod R) * (N mod R) ≡ᵣ x * -1.
    Proof using N'_good.
      rewrite <- N'_good', Z.mul_assoc.
      unfold Z.equiv_modulo; push_Zmod.
      reflexivity.
    Qed.

    Section redc.
      Context (T : Z).

      Local Notation m := (((T mod R) * N') mod R).
      Local Notation prereduce := (prereduce N R N').

      Local Ltac t_fin_correct :=
        unfold Z.equiv_modulo; push_Zmod; autorewrite with zsimplify; reflexivity.

      Lemma prereduce_correct : prereduce T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        transitivity ((T + m * N) * R').
        { unfold prereduce.
          autorewrite with zstrip_div; push_Zmod.
          rewrite N'_good'_alt.
          autorewrite with zsimplify pull_Zmod.
          reflexivity. }
        t_fin_correct.
      Qed.

      Lemma reduce_correct : reduce N R N' T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold reduce.
        break_match; rewrite prereduce_correct; t_fin_correct.
      Qed.

      Lemma partial_reduce_correct : partial_reduce N R N' T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold partial_reduce.
        break_match; rewrite prereduce_correct; t_fin_correct.
      Qed.

      Lemma reduce_via_partial_correct : reduce_via_partial N R N' T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold reduce_via_partial.
        break_match; rewrite partial_reduce_correct; t_fin_correct.
      Qed.

      Let m_small : 0 <= m < R. Proof. auto with zarith. Qed.

      Section generic.
        Lemma prereduce_in_range_gen B
        : 0 <= N
          -> 0 <= T <= R * B
          -> 0 <= prereduce T < B + N.
        Proof using N_reasonable m_small. unfold prereduce; auto with zarith nia. Qed.
      End generic.

      Section N_very_small.
        Context (N_very_small : 0 <= 4 * N < R).

        Lemma prereduce_in_range_very_small
          : 0 <= T <= (2 * N - 1) * (2 * N - 1)
            -> 0 <= prereduce T < 2 * N.
        Proof using N_reasonable N_very_small m_small. pose proof (prereduce_in_range_gen N); nia. Qed.
      End N_very_small.

      Section N_small.
        Context (N_small : 0 <= 2 * N < R).

        Lemma prereduce_in_range_small
          : 0 <= T <= (2 * N - 1) * (N - 1)
            -> 0 <= prereduce T < 2 * N.
        Proof using N_reasonable N_small m_small. pose proof (prereduce_in_range_gen N); nia. Qed.

        Lemma prereduce_in_range_small_fully_reduced
          : 0 <= T <= 2 * N
            -> 0 <= prereduce T <= N.
        Proof using N_reasonable N_small m_small. pose proof (prereduce_in_range_gen 1); nia. Qed.
      End N_small.

      Section N_small_enough.
        Context (N_small_enough : 0 <= N < R).

        Lemma prereduce_in_range_small_enough
          : 0 <= T <= R * R
            -> 0 <= prereduce T < R + N.
        Proof using N_reasonable N_small_enough m_small. pose proof (prereduce_in_range_gen R); nia. Qed.

        Lemma reduce_in_range_R
          : 0 <= T <= R * R
            -> 0 <= reduce N R N' T < R.
        Proof using N_reasonable N_small_enough m_small.
          intro H; pose proof (prereduce_in_range_small_enough H).
          unfold reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.

        Lemma partial_reduce_in_range_R
          : 0 <= T <= R * R
            -> 0 <= partial_reduce N R N' T < R.
        Proof using N_reasonable N_small_enough m_small.
          intro H; pose proof (prereduce_in_range_small_enough H).
          unfold partial_reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.

        Lemma reduce_via_partial_in_range_R
          : 0 <= T <= R * R
            -> 0 <= reduce_via_partial N R N' T < R.
        Proof using N_reasonable N_small_enough m_small.
          intro H; pose proof (prereduce_in_range_small_enough H).
          unfold reduce_via_partial, partial_reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.
      End N_small_enough.

      Section unconstrained.
        Lemma prereduce_in_range
          : 0 <= T <= R * N
            -> 0 <= prereduce T < 2 * N.
        Proof using N_reasonable m_small. pose proof (prereduce_in_range_gen N); nia. Qed.

        Lemma reduce_in_range
        : 0 <= T <= R * N
          -> 0 <= reduce N R N' T < N.
        Proof using N_reasonable m_small.
          intro H; pose proof (prereduce_in_range H).
          unfold reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.

        Lemma partial_reduce_in_range
        : 0 <= T <= R * N
          -> Z.min 0 (R - N) <= partial_reduce N R N' T < 2 * N.
        Proof using N_reasonable m_small.
          intro H; pose proof (prereduce_in_range H).
          unfold partial_reduce, prereduce in *; break_match; Z.ltb_to_lt;
            apply Z.min_case_strong; nia.
        Qed.

        Lemma reduce_via_partial_in_range
        : 0 <= T <= R * N
          -> Z.min 0 (R - N) <= reduce_via_partial N R N' T < N.
        Proof using N_reasonable m_small.
          intro H; pose proof (partial_reduce_in_range H).
          unfold reduce_via_partial in *; break_match; Z.ltb_to_lt; lia.
        Qed.
      End unconstrained.

      Section alt.
        Context (N_in_range : 0 <= N < R)
                (T_representable : 0 <= T < R * R).
        Lemma partial_reduce_alt_eq : partial_reduce_alt N R N' T = partial_reduce N R N' T.
        Proof using N_in_range N_reasonable T_representable m_small.
          assert (0 <= T + m * N < 2 * (R * R)) by nia.
          assert (0 <= T + m * N < R * (R + N)) by nia.
          assert (0 <= (T + m * N) / R < R + N) by auto with zarith.
          assert ((T + m * N) / R - N < R) by lia.
          assert (R * R <= T + m * N -> R <= (T + m * N) / R) by auto with zarith.
          assert (T + m * N < R * R -> (T + m * N) / R < R) by auto with zarith.
          assert (H' : (T + m * N) mod (R * R) = if R * R <=? T + m * N then T + m * N - R * R else T + m * N)
            by (break_match; Z.ltb_to_lt; autorewrite with zsimplify; lia).
          unfold partial_reduce, partial_reduce_alt, prereduce.
          rewrite H'; clear H'.
          simplify_repeated_ifs.
          set (m' := m) in *.
          autorewrite with zsimplify; push_Zmod; autorewrite with zsimplify; pull_Zmod.
          break_match; Z.ltb_to_lt; autorewrite with zsimplify; try reflexivity; lia.
        Qed.

        Lemma reduce_via_partial_alt_eq : reduce_via_partial_alt N R N' T = reduce_via_partial N R N' T.
        Proof.
            cbv [reduce_via_partial_alt reduce_via_partial].
            rewrite partial_reduce_alt_eq by lia. reflexivity.
        Qed.
      End alt.
    End redc.

    (** * Arithmetic in Montgomery form *)
    Section arithmetic.
      Local Infix "*" := (mul N R N') : montgomery_scope.

      Local Notation to_montgomery := (to_montgomery N R N').
      Local Notation from_montgomery := (from_montgomery N R N').
      Lemma to_from_montgomery a : to_montgomery (from_montgomery a) ≡ a.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold to_montgomery, from_montgomery.
        transitivity ((a * 1) * 1); [ | apply f_equal2; lia ].
        rewrite <- !R'_good, !reduce_correct.
        unfold Z.equiv_modulo; push_Zmod; pull_Zmod.
        apply f_equal2; lia.
      Qed.
      Lemma from_to_montgomery a : from_montgomery (to_montgomery a) ≡ a.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold to_montgomery, from_montgomery.
        rewrite !reduce_correct.
        transitivity (a * ((R * (R * R' mod N) * R') mod N)).
        { unfold Z.equiv_modulo; push_Zmod; pull_Zmod.
          apply f_equal2; lia. }
        { repeat first [ rewrite R'_good
                       | reflexivity
                       | push_Zmod; pull_Zmod; progress autorewrite with zsimplify
                       | progress unfold Z.equiv_modulo ]. }
      Qed.

      Theorem mul_correct x y : from_montgomery (x * y) ≡ from_montgomery x * from_montgomery y.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold from_montgomery, mul.
        rewrite !reduce_correct; apply f_equal2; lia.
      Qed.
      Theorem mul_correct_to x y : to_montgomery (x * y) ≡ (to_montgomery x * to_montgomery y)%montgomery.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold to_montgomery, mul.
        rewrite !reduce_correct.
        transitivity (x * y * R * 1 * 1 * 1);
          [ rewrite <- R'_good at 1
          | rewrite <- R'_good at 1 2 3 ];
          autorewrite with zsimplify;
          unfold Z.equiv_modulo; push_Zmod; pull_Zmod.
        { apply f_equal2; lia. }
        { apply f_equal2; lia. }
      Qed.
    End arithmetic.
  End redc.
End montgomery.

Module Import LocalizeEquivModuloInstances := Z.RemoveEquivModuloInstances Nop.


Require Import Bool.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Lib.EqDec.

Definition FunExt := forall (A B: Type) (f g: A -> B), (forall x: A, f x = g x) -> f = g.

Definition set (A: Type) : Type := A -> bool.

Definition set_filter {A: Type} (p: A-> bool) (s: set A) : set A :=
  fun x: A => if p x then s x else false.

Definition set_union {A: Type} (s s': set A) : set A :=
  fun x: A => (s x) || (s' x).

Definition set_intersection {A: Type} (s s': set A) : set A :=
  fun x: A => (s x) && (s' x).

Definition set_complement {A: Type} (s: set A) : set A :=
  fun x: A => negb (s x).

Definition set_add {A: Type} `{EqDec A} (a: A) (s: set A)  : set A :=
  fun x: A => if eqf x a then true else s x.

Fixpoint list_to_set {A: Type} `{EqDec A} (l: list A) : set A :=
match l with
| []        => fun _ => false
| (h :: l') => set_add h (list_to_set l')
end.

Theorem double_set_complement {A: Type} `{FunExt} `{EqDec A} (s: set A) :
  s = set_complement (set_complement s).
Proof.
  unfold set_complement. apply H. intros x. destruct (s x); auto.
Qed.

Theorem list_to_set_correct {A: Type} `{EqDec A} (l: list A) :
  forall x: A, reflect (In x l) (list_to_set l x).
Proof.
  intros x. destruct (list_to_set l x) eqn:e; constructor.
  - induction l; cbn in *; [inversion e|].
    unfold set_add in *. rewrite eqf_sym in e. destruct (eqf a x) eqn:e'.
    + left. apply eqf_iff. auto.
    + right. auto.
  - intros I. induction l; cbn in *; [inversion I|].
    unfold set_add in *. destruct I.
    + subst. rewrite eqf_refl in e. inversion e.
    + apply IHl; [|auto]. destruct (eqf x a); [inversion e | auto].
Qed.

Definition mset (A: Type) : Type := A -> nat.

Definition mset_filter {A: Type} (p: A-> bool) (s: mset A) : mset A :=
  fun x: A => if p x then s x else 0.

Definition mset_union {A: Type} (s s': mset A) : mset A :=
  fun x: A => (s x) + (s' x).

Definition mset_intersection {A: Type} (s s': mset A) : mset A :=
  fun x: A => min (s x) (s' x).

Definition mset_add {A: Type} `{EqDec A} (a: A) (s: mset A)  : mset A :=
  fun x: A => if eqf x a then S (s x) else s x.

Fixpoint list_to_mset {A: Type} `{EqDec A} (l: list A) : mset A :=
match l with
| []        => fun _ => O
| (h :: l') => mset_add h (list_to_mset l')
end.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (x : natural) : natural :=
  plus (mult x lf1) lf1.


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

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

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

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

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.
(* Requires No helper lemma *)
Theorem theorem0 : forall (x : natural) (y : lst), eq (len (insort x y)) (Succ (len y)).
Proof.
   intros.
  induction y.
  - simpl. destruct (less x n) eqn:?.
    + reflexivity.
    + simpl. rewrite IHy. reflexivity.
    - reflexivity.
Qed.


    (*nandb*)
    Definition neg (b:bool):bool :=
        match b with
        | true => false
        | false => true
        end.
    Notation "~ x" := (neg x).

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

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

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

    Example testnandb1: (nandb true false)=true.
    Proof. simpl. reflexivity. Qed.
    Example testnandb2: (nandb false false)=true.
    Proof. simpl. reflexivity. Qed.
    Example testnandb3: (nandb false true)=true.
    Proof. simpl. reflexivity. Qed.
    Example testnandb4: (nandb true true)=false.
    Proof. simpl. reflexivity. Qed.

    (*andb3*)
    Definition and (b1:bool) (b2:bool):bool :=
        match b1 with
        |false => false
        |true => b2
        end.
    Notation "a && b" := (and a b).

    Definition andb3 (b1:bool) (b2:bool) (b3:bool):bool :=
        match b1 with
        |false => false
        |true => b2 && b3
        end.
    Example test_andb31: (andb3 true true true) = true.
    Proof. simpl. reflexivity. Qed.
    Example test_andb32: (andb3 false true true) = false.
    Proof. simpl. reflexivity. Qed.
    Example test_andb33: (andb3 true false true) = false.
    Proof. simpl. reflexivity. Qed.
    Example test_andb34: (andb3 true true false) = false.
    Proof. simpl. reflexivity. Qed.

    (*factorial*)
    Fixpoint evenb (n:nat) :bool:=
        match n with
        |O =>true
        |S O => false
        |S (S n) => evenb n
        end.

    Fixpoint add (n m:nat): nat :=
        match n with
        |0=>m
        |S n=> S (add n m)
        end.
    Example testadd: add 2 3 = 5.
    Proof. simpl. reflexivity. Qed.

    Fixpoint mult (n m:nat) :nat :=
        match n with
        |0 =>0
        |S n=>add m (mult n m)
        end.
    Example testmult: mult 2 3 = 6.
    Proof. simpl. reflexivity. Qed.

    Fixpoint minus (n m :nat):nat:=
        match n,m with
        |0 ,_ =>0
        |_ ,0 =>n
        |S n ,S m =>minus n m
        end.
    Example testminus : minus 2 3 =0.
    Proof. simpl. reflexivity. Qed.

    Fixpoint factorial (n:nat):nat :=
        match n with
        |0 =>1
        |S n' => (S n')*(factorial n')
        end.
    Example test_factorial1: (factorial 3) = 6.
    Proof. simpl. reflexivity. Qed.
    Example test_factorial2: (factorial 5) = (mult 10 12).
    Proof. simpl. reflexivity. Qed.

    Notation "x + y" := (add x y)
                       (at level 50, left associativity)
                       : nat_scope.
    Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
    Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

    (*ltb*)
    Fixpoint eqb (n m : nat) : bool :=
        match n with
        | 0=> match m with
            | 0 => true
            | S m' => false
            end
        | S n' => match m with
            | 0 => false
            | S m' => eqb n' m'
            end
    end.
    Fixpoint leb (n m : nat) : bool :=
        match n with
        | 0 =>true
        | S n' =>
            match m with
            | 0 => false
            | S m' => leb n' m'
            end
        end.
    Example test_leb1: leb 2 2 = true.
    Proof. simpl. reflexivity. Qed.
    Example test_leb2: leb 2 4 = true.
    Proof. simpl. reflexivity. Qed.
    Example test_leb3: leb 4 2 = false.
    Proof. simpl. reflexivity. Qed.
    Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
    Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
    Example test_leb3': (4 <=? 2) = false.
    Proof. simpl. reflexivity. Qed.

    Definition ltb (n m:nat):bool :=
        match m with
        |0=>false
        |S m' => (n<=?m')
        end.
    Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.
    Example test_ltb1: (ltb 2 2) = false.
    Proof. simpl. reflexivity. Qed.
    Example test_ltb2: (ltb 2 4) = true.
    Proof. simpl. reflexivity. Qed.
    Example test_ltb3: (ltb 4 2) = false.
    Proof. simpl. reflexivity. Qed.

    Theorem add_id_example: forall n m:nat,
        n=m -> n+n = m+m .
    Proof.
        intros n m.
        intros H.
        rewrite <-H.
        reflexivity.
    Qed.

    Theorem add_id_exercise: forall n m o:nat,
    n = m ->m = o ->n+m=m+o .
    Proof.
        intros n m o.
        intros H.
        intros J.
        rewrite->H.
        rewrite<-J.
        reflexivity.
    Qed.

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

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

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

    Theorem andb_true_elim2:forall b c:bool,
    andb b c = true -> c = true .
    Proof.
        intros b c H.
        destruct c eqn:EC.
        - reflexivity.
        - rewrite<-H. destruct b eqn:EB.
            -- reflexivity.
            -- reflexivity.
    Qed.

    Theorem zero_nbeq_plus_1: forall n:nat,
    0 =? (n+1) = false.
    Proof.
        intros n. destruct n.
        - reflexivity.
        - reflexivity.
    Qed.

    Theorem identity_fn_applied_twice:
    forall (f:bool -> bool),
    (forall (x:bool),f x = x)->
    forall (b:bool),f (f b) = b.
    Proof.
        intros H J.
        destruct b eqn:EB.
        - rewrite->J.  rewrite->J. reflexivity.
        - rewrite->J.  rewrite->J. reflexivity.
    Qed.

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

    Theorem negation_fn_applied_twice:
    forall (f:bool->bool),
    (forall (x:bool),f x = neg x)->
    forall (b:bool), f (f b) = b.
    Proof.
        intros H J.
        destruct b eqn:EB.
        - rewrite->J.  rewrite->J. reflexivity.
        - rewrite->J.  rewrite->J. reflexivity.
    Qed.

    Theorem andb_eq_orb :
    forall (b c : bool),
    (andb b c = orb b c) -> b = c.
    Proof.
        intros b c. destruct b eqn:EB.
        - simpl. intros H. rewrite<-H. reflexivity.
        - simpl. intros H. rewrite->H. reflexivity.
    Qed.

    Inductive bin: Type:=
    | Z
    | B0 (n:bin)
    | B1 (n:bin).

    Fixpoint incr (m:bin):bin :=
        match m with
        | Z=>B1 Z
        | B0 n=>B1 n
        | B1 n=>B0 (incr n)
    end.

    Fixpoint bin_to_nat (m :bin) :nat :=
        match m with
        | Z=>O
        | B0 n => (bin_to_nat n) + (bin_to_nat n)
        | B1 n => S ((bin_to_nat n) + (bin_to_nat n))
    end.

    Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
    Proof. simpl. reflexivity. Qed.
    Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
    Proof. simpl. reflexivity. Qed.
    Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
    Proof. simpl. reflexivity. Qed.
    Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
    Proof. simpl. reflexivity. Qed.
    Example test_bin_incr5 :
            bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
    Proof. simpl. reflexivity. Qed.
    Example test_bin_incr6 :
            bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
    Proof. simpl. reflexivity. Qed.


Require Import Arith Omega Reals.

(* The standard recursive definition of the Fibonacci numbers *)

Open Scope nat_scope.

Fixpoint fib n :=
  match n with
    0 => 0
  | (S n) => (* this nested match trick helps coq prove n and m are decreasing [1] *)
      match n with
        0 => 1
      | (S m) => fib n + fib m
      end
  end.

(* F_{n+2} = F_{n+1} + F_n *)
Lemma fib_rec : forall n, fib (S (S n)) = fib n + fib (S n).
induction n.
trivial.
simpl.
omega.
Qed.

Close Scope nat_scope.

(* Closed-form definition of the Fibonacci numbers using the golden ratio (phi) [2] *)

Open Scope R_scope.

Definition phi  := (1 + sqrt 5)/2.
Definition phi' := (1 - sqrt 5)/2.

Definition F n := (phi ^ n - phi' ^ n)/(sqrt 5).

(* Next we prove some handy results about phi and phi' *)

(* This is only used to prove sqrt 5 <> 0 but it's handy to have around i suppose [2] *)
Lemma sqrt_pos_neq_0 : forall n, 0 < n -> sqrt n <> 0.
intros n Hgt.
generalize (Rlt_le 0 n Hgt).
intro Hge.
red.
intro Hs_eq_z.
generalize sqrt_eq_0 n Hge Hs_eq_z.
intro H.
absurd (n = 0).
auto with *.
apply H; assumption.
Qed.

Lemma sqrt5_neq_0 : sqrt 5 <> 0.
apply sqrt_pos_neq_0.
prove_sup0. (* proves 0 < 5 *)
Qed.

(* Split this out to shorten later proofs [3] *)
Lemma pow2_sqrt : forall n, 0 <= n -> sqrt n ^ 2 = n.
intros n Hle.
simpl.
replace (sqrt n * (sqrt n * 1)) with (sqrt n * sqrt n) by field. (* 'by field' means 'do basic algebra please' *)
rewrite sqrt_def by (exact Hle). (* sqrt n * sqrt n -> n *)
reflexivity.
Qed.

(* Now: proofs that phi and phi' are the roots of x^2 = x + 1 (CLRS 3.2-6) *)

Lemma phi_root : phi ^ 2 = phi + 1.
unfold phi.
replace (((1 + sqrt 5) / 2) ^ 2) with ((1 + 2 * sqrt 5 + sqrt 5 ^ 2) / 4) by field.
rewrite pow2_sqrt by (unfold Rle; left; prove_sup0). (* sqrt 5 ^ 2 -> 5; 'by ...' proves 0 <= 5 *)
field.
Qed.

Lemma phi'_root : phi' ^ 2 = phi' + 1.
unfold phi'.
replace (((1 - sqrt 5) / 2) ^ 2) with ((1 - 2 * sqrt 5 + sqrt 5 ^ 2) / 4) by field.
rewrite pow2_sqrt by (unfold Rle; left; prove_sup0).
field.
Qed.

(* Slightly generalize the above results for higher powers *)
Lemma phi_root_n : forall n, (phi ^ S (S n)) = (phi ^ n + phi ^ (S n)).
intro.
replace  (phi ^ S (S n)) with ((phi ^ 2) * (phi ^ n)) by (simpl; field). (* field can't do powers, so simplify those to multiplication first *)
rewrite phi_root.
simpl.
field.
Qed.

Lemma phi'_root_n : forall n, (phi' ^ S (S n)) = (phi' ^ n + phi' ^ (S n)).
intro.
replace  (phi' ^ S (S n)) with ((phi' ^ 2) * (phi' ^ n)) by (simpl; field).
rewrite phi'_root.
simpl.
field.
Qed.

(* The main result! (CLRS 3.2-7) *)

(* If we attempt to prove F n = fib n by induction on n, we run into trouble because the inductive step
   needs access to the /two/ 'rungs' before it. You can't generally do that -- i think it could allow
   you to make use of an unbounded number of previous 'rungs', which could lead to unsoundness. All you
   get is the 'rung' before. That is, to prove F (n + 1) = fib (n + 1), we need to know F n = fib n AND
   F (n - 1) = fib (n - 1), but we only get F n = fib n. :(

   So, instead, here's an odd proof technique that gives us access to more than one 'rung' at a time:
   Prove something stronger: /two steps/ at once, giving us access to the previous two 'rungs' simultaneously!
   It's just like the usual 'climbing a ladder' analogy, but you have three legs instead of two.

   Technically this is stronger, but practically it is not any more difficult to do.
   The inductive step now gives us two hypotheses:
     IHn : F n = fib n
     IHSn : F (n + 1) = fib (n + 1)
   and two goals:
     1: F (n + 1) = fib (n + 1)
     2: F (n + 2) = fib (n + 2)
   The 'extra' goal (goal 1) that this technique adds is exactly one of the induction hypotheses!
   Finally, goal 2 is where the "actual" proof happens: algebra it into F (n + 1) + F n = fib (n + 1) + fib n,
   then use the inductive hypotheses to prove the equality.
*)
(* Note: INR ('inject nat to real') converts natural numbers (the realm of fib) to reals (the realm of F) [4] *)
Lemma F_eq_fib' : forall n, F n = INR (fib n) /\ F (S n) = INR (fib (S n)).
induction n.
+ (* base case: split it up and do the arithmetic *)
  unfold F; unfold phi; unfold phi'.
  split; simpl; field; apply sqrt5_neq_0.
+ (* inductive case *)
  destruct IHn as [IHn IHSn]. (* make that inductive hypothesis more presentable *)
  split. (* split the goal into two, just like solomon would have wanted *)
  exact IHSn. (* goal 1: easy peasy; already done it! *)
  unfold F in *. (* goal 2: actually requires some thinking *)
  rewrite phi_root_n. (* Use phi^2 = phi + 1 to make enough phi terms for F n and F (n + 1) *)
  rewrite phi'_root_n.
  replace ((phi ^ n + phi ^ S n - (phi' ^ n + phi' ^ S n)) / sqrt 5)
    with (((phi ^ n - phi' ^ n) / sqrt 5) + ((phi ^ S n - phi' ^ S n) / sqrt 5))
    by (simpl; field; apply sqrt5_neq_0).
    (* algebra ain't hard when you got a, uh, piece of scratch paper and a computer to check it! *)
  rewrite IHn. (* ahh, the refreshing taste of induction *)
  rewrite IHSn.
  rewrite <- plus_INR. (* INR (fib n) + INR (fib (n + 1)) -> INR (fib n + fib (n + 1)) *)
  rewrite fib_rec. (* fib (n + 2) -> fib n + fib (n + 1) *)
  trivial.
Qed.

(* The actual result we were after follows directly from the more complex result. *)
Lemma F_eq_fib : forall n, F n = INR (fib n).
apply F_eq_fib'.
Qed.

(* and that's all, folks! *)

(* Foontotes:
 [1]: I learned this trick from https://www.irif.fr/~letouzey/hofstadter_g/doc/Fib.html
 [2]: This proof generalized from the proof of sqrt2_neq_0 from the Rtrigo_calc library; see
      https://www.cs.princeton.edu/courses/archive/fall07/cos595/stdlib/html/Coq.Reals.Rtrigo_calc.html#sqrt2_neq_0
 [3]: They give us sqrt_pow2: forall x : R, 0 <= x -> sqrt (x ^ 2) = x but not the other way around!
 [4]: Defined in Raxioms: https://coq.inria.fr/distrib/8.4pl6/stdlib/Coq.Reals.Raxioms.html#INR
      but see Rineq (???) for handy theorems: https://coq.inria.fr/library/Coq.Reals.RIneq.html#lab145
*)


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Extension for permutation, especially for computable permutation.
  author    : ZhengPu Shi
  date      : 2022.06

  remark    :
  1. compute permutation of a list, such as
     perm [a;b;c] => [[a;b;c]; [a;c;b]; [b;a;c]; [b;c;a]; [c;a;b]; [c;b;a]]
     perm [1;2;3] => [[1;2;3]; [1;3;2]; [2;1;3]; [2;3;1]; [3;1;2]; [3;2;1]]
 *)

Require Import SetoidListExt.
Require Import SafeNatFun.Vector.

(* ######################################################################### *)
(** * reverse-order-number of a list *)
Section ronum.

  Context {A : Type}.
  Context {Altb : A -> A -> bool}.
  Infix "<?" := Altb.
  (* Context {Alt : A -> A -> Prop}. *)
  (* Context {Alt_dec : Decidable Alt}. *)

  Definition ronum1 (a : A) (l : list A) : nat :=
    fold_left (fun (n : nat) (b : A) => n + (if b <? a then 1 else 0)) l 0.

  Fixpoint ronum (l : list A) : nat :=
    match l with
    | [] => 0
    | x :: l' => ronum1 x l' + ronum l'
    end.

  (** ** parity of a list *)
  Section parity.

    (** Give speciall name for parity *)
    Definition Parity := bool.
    Definition POdd := true.
    Definition PEven := false.

    (** Calulate parity of a list *)
    Definition perm_parity (l : list A) : Parity := odd (ronum l).

    (** Is two list have different parity? *)
    Definition perm_parity_diff (l1 l2 : list A) : Prop :=
      let p1 := perm_parity l1 in
      let p2 := perm_parity l2 in
      p1 = (negb p2).

  End parity.

End ronum.

(* Compute ronum (Altb:=Nat.ltb) [2;4;3;1]. *)
(* Compute ronum (Altb:=Nat.ltb) [2;1;3;4]. *)

(* ######################################################################### *)
(** * Permutation of a list *)
Module Perm_with_list.

  (** ** Permutation of a list of n elements *)
  Section perm.
    Context {A : Type} {A0 : A}.

    (** Get k-th element and remaining elements from a list *)
    Fixpoint pick (l : list A) (k : nat) : A * list A :=
      match k with
      | 0 => (hd A0 l, tl l)
      | S k' =>
          match l with
          | [] => (A0, [])
          | x :: l' =>
              let (a,l0) := pick l' k' in
              (a, [x] ++ l0)
          end
      end.

    Section test.
      Variable a b c : A.
      Let l := [a;b;c].
      (* Compute pick l 0.     (* = (a, [b; c]) *) *)
      (* Compute pick l 1.     (* = (b, [a; c]) *) *)
      (* Compute pick l 2.     (* = (c, [a; b]) *) *)
      (* Compute pick l 3.     (* = (A0, [a; b; c]) *) *)
    End test.

    (** Get permutation of a list with a special level number *)
    Fixpoint perm_aux (n : nat) (l : list A) : list (list A) :=
      match n with
      | 0 => [[]]
      | S n' =>
          let d1 := map (fun i => pick l i) (seq 0 n) in
          let d2 :=
            map (fun k : A * list A =>
                   let (x, lx) := k in
                   let d3 := perm_aux n' lx in
                   map (fun l1 => [x] ++ l1) d3) d1 in
          concat d2
      end.

    Section test.
      Variable a b c : A.
      Let l := [a;b;c].
      (* Compute perm_aux 0 l.     (* = [[]] *) *)
      (* Compute perm_aux 1 l.     (* = [[a]] *) *)
      (* Compute perm_aux 2 l.     (* = [[a; b]; [b; a]] *) *)
    (* Compute perm_aux 3 l.     (* = [[a; b; c]; [a; c; b]; [b; a; c]; [b; c; a];  *)
     (*                              [c; a; b]; [c; b; a]] *) *)
    End test.

    (** Get permutation of a list *)
    Definition perm (l : list A) : list (list A) := perm_aux (length l) l.

    Section test.
      Variable a b c : A.
      (* Compute perm [a;b;c]. *)
      (* = [[a; b; c]; [a; c; b]; [b; a; c]; [b; c; a]; [c; a; b]; [c; b; a]] *)
    End test.

    (** Length of permutation *)
    Definition Pn (l : list A) := length (perm l).

    (** Pn of cons.
      Example: Pn [a;b;c;d] = 4 * Pn [a;b;c] *)
    Lemma Pn_cons : forall (a : A) (l : list A), Pn (a :: l) = (length (a :: l)) * (Pn l).
    Proof.
      intros. simpl. unfold Pn.
      unfold perm. simpl. rewrite app_length. rewrite map_length. f_equal.
      rewrite List.map_map.
      rewrite concat_length.
      rewrite List.map_map.
    Admitted.

    (** Length of permutation equal to the factorial of the length *)
    Lemma Pn_eq : forall l, Pn l = fact (length l).
    Proof.
      induction l; simpl; auto.
      rewrite Pn_cons. rewrite IHl. simpl. auto.
    Qed.

    (** The inverse number of a permutation *)
    (* Definition inv_no             (*  *) *)

  End perm.

  (* Compute perm [1;2]. *)
  (* Compute perm [1;2;3]. *)
  (* Compute perm [1;2;3;4]. *)
End Perm_with_list.

(* ######################################################################### *)
(** * Permutation of a vector *)
Module Perm_with_vector.

  Context {A : Type} {A0 : A}.
  Context {Altb : A -> A -> bool}.
  Infix "!" := (vnth (A0:=A0)) : vec_scope.

  (** ** Permutation of a list of n elements *)
  Section perm.

    (** Get k-th element and remaining elements from a vector *)
    Definition pick {n : nat} (v : @vec A (S n)) (k : nat) : A * (vec n) :=
      (v ! k, vremove (A0:=A0) v k).

    Section test.
      Variable a0 a b c : A.
      Let l := l2v a0 3 [a;b;c].
      (* Compute pick l 0.     (* = (a, [b; c]) *) *)
      (* Compute pick l 1.     (* = (b, [a; c]) *) *)
      (* Compute pick l 2.     (* = (c, [a; b]) *) *)
      (* Compute pick l 3.     (* = (A0, [a; b; c]) *) *)
      (* Compute v2l (vremove l 4). *)
    End test.

    (** Get permutation of a vector *)
    Fixpoint perm {n : nat} : @vec A n -> list (@vec A n) :=
      match n with
      | 0 => fun _ => [vec0 (A0:=A0)]
      | S n' => fun (v : vec (S n')) =>
          let d1 := map (fun i => pick v i) (seq 0 n) in
          let d2 :=
            map (fun k : A * @vec A n' =>
                   let (x, v') := k in
                   let d3 := perm v' in
                   map (fun v0 => vcons (A0:=A0) x v') d3) d1 in
          concat d2
      end.

    Section test.
      Variable a0 a b c : A.
      (* Compute vl2dl (perm (l2v a0 0 [])). *)
      (* Compute vl2dl (perm (l2v a0 1 [a])). *)
      (* Compute vl2dl (perm (l2v a0 2 [a;b])). *)
      (* Compute vl2dl (perm (l2v a0 3 [a;b;c])). *)
      (* = [[a; b; c]; [a; b; c]; [b; a; c]; [b; a; c]; [c; a; b]; [c; a; b]] *)
    End test.

    (** Length of permutation *)
    Definition Pn {n} (v : @vec A n) := length (perm v).

    (** Pn of cons.
      Example: Pn [a;b;c;d] = 4 * Pn [a;b;c] *)
    (* Lemma Pn_cons : forall {n} (a : A) (v : @vec A n), Pn (a :: v) = (length (a :: l)) * (Pn l). *)
    (* Proof. *)
    (*   intros. simpl. unfold Pn. *)
    (*   unfold perm. simpl. rewrite app_length. rewrite map_length. f_equal. *)
    (*   rewrite List.map_map. *)
    (*   rewrite concat_length. *)
    (*   rewrite List.map_map. *)
    (* Admitted. *)

    (** Length of permutation equal to the factorial of the length *)
    Lemma Pn_eq : forall n (v : @vec A n), Pn v = fact n.
    Proof.
    (*   induction l; simpl; auto. *)
    (*   rewrite Pn_cons. rewrite IHl. simpl. auto. *)
      (* Qed. *)
      Abort.

    (** The inverse number of a permutation *)
    (* Definition inv_no             (*  *) *)

  End perm.

  (* Compute vl2dl (perm (l2v 0 2 [1;2])). *)
  (* Compute vl2dl (perm (l2v 0 3 [1;2;3])). *)
  (* Compute vl2dl (perm (l2v 0 4 [1;2;3;4])). *)

  (** ** parity of a vector *)
  Definition perm_parity {n} (v : @vec A n) : Parity :=
    perm_parity (Altb:=Altb) (v2l v).
  Definition perm_parity_diff {n} (v1 v2 : @vec A n) : Prop :=
    perm_parity_diff (Altb:=Altb) (v2l v1) (v2l v2).

  (** ** transposition, exchange, swap 对换 *)
  Section exchange.

    Definition vexchg {n} (v : @vec A n) (i0 i1 : nat) : @vec A n :=
      mk_vec (A0:=A0) (fun i =>
                if i =? i0
                then v!i1
                else (if i =? i1 then v!i0 else v!i)).

    (** 对换相邻位置改变排列的奇偶性 *)
    Theorem vexchg_swap2close_parity : forall {n} (v : @vec A n) i0 i1,
        i0 < n -> i1 < n -> (i0 = S i1 \/ i1 = S i0) ->
        perm_parity_diff v (vexchg v i0 i1).
    Proof.
      (* 教科书上的证明很巧妙，难以形式化的描述出来 *)
      intros. unfold vexchg, perm_parity_diff.
      unfold PermutationExt.perm_parity_diff, PermutationExt.perm_parity.
      unfold vnth,mnth. solve_mnth; try lia.
      clear l0 l l1.
      unfold vec in *. mat_to_fun. simpl. unfold v2l. simpl.
      (* key part *)
      destruct H1; subst.
      - rename i1 into j.
        revert v j H H0. induction n; try easy.
        intros. simpl.
        rewrite <- ?seq_shift. rewrite ?map_map.
        destruct j.
        + simpl.
          rewrite Nat.odd_add.
    Abort.

    (** 对换改变排列的奇偶性 *)
    Theorem vexchg_swap2_parity : forall {n} (v : @vec A n),
        (forall i0 i1, i0 < n -> i1 < n -> i0 <> i1 -> perm_parity_diff v (vexchg v i0 i1)).
    Proof.
      (* 教科书上的证明很巧妙，难以形式化的描述出来 *)
      Admitted.

  End exchange.

  (* Let v := l2v 0 3 [1;2;3]. *)
  (* Compute v2l (vexchg v 0 1). *)
  (* Compute v2l (vexchg v 0 2). *)

  (** ** odd/even permutation *)
  Section odd_even.
    Context {A : Type}.
    Context {Altb : A -> A -> bool}.

    Definition odd_perm (l : list A) : bool := odd (ronum (Altb:=Altb) l).
    Definition even_perm (l : list A) : bool := even (ronum (Altb:=Altb) l).
  End odd_even.

  (** ** transposition, exchange, swap *)
  Section exchange.

  End exchange.
End Perm_with_vector.

(* ######################################################################### *)
(** * Determinant *)


Require Import List.
Import ListNotations.

Set Implicit Arguments.

Section tree.
  (* The tree is parametrized on the type of data stored at the leaves. *)
  Variable A : Type.

  (* Each node of the tree contains a list of subtrees.
     Coq does not generate a useful induction scheme for such types,
     so we just tell it not to generate anything, and we'll write our own. *)
  Local Unset Elimination Schemes.

  Inductive tree : Type :=
  | atom : A -> tree
  | node : list tree -> tree
  .

  (* Here is an actually useful recursion principle for tree,
     which requires an additional motive P_list. *)
  Section tree_rect.
    Variable P : tree -> Type.
    Variable P_list : list tree -> Type.
    Hypothesis P_nil : P_list [].
    Hypothesis P_cons : forall t l, P t -> P_list l -> P_list (t :: l).
    Hypothesis P_atom : forall a, P (atom a).
    Hypothesis P_node : forall l, P_list l -> P (node l).

    Fixpoint tree_rect (t : tree) : P t :=
      let fix go_list (l : list tree) : P_list l :=
          match l with
          | [] => P_nil
          | t :: l => P_cons (tree_rect t) (go_list l)
          end
      in
      match t with
      | atom a => P_atom a
      | node l => P_node (go_list l)
      end.
  End tree_rect.

  (* Setting P_list := List.Forall P is a reasonable default. *)
  Section tree_ind.
    Variable P : tree -> Prop.

    Hypothesis P_atom : forall a, P (atom a).
    Hypothesis P_node : forall l, List.Forall P l -> P (node l).

    Definition tree_ind (t : tree) : P t :=
      tree_rect P (List.Forall P)
                (List.Forall_nil _)
                (fun t l Pt Pl => List.Forall_cons _ Pt Pl) P_atom P_node t.
  End tree_ind.

  Variable A_eq_dec : forall a1 a2 : A, {a1 = a2} + {a1 <> a2}.

  Fixpoint tree_eq_dec (t1 t2 : tree) : {t1 = t2} + {t1 <> t2}.
    unshelve refine (
    let fix go_list (l1 l2 : list tree) : {l1 = l2} + {l1 <> l2}  :=
        match l1 with
        | [] =>
          match l2 with
          | [] => left eq_refl
          | _ => right _
          end
        | t1 :: l1 =>
          match l2 with
          | [] => right _
          | t2 :: l2 =>
            match tree_eq_dec t1 t2 with
            | left _ =>
              match go_list l1 l2 with
              | left _ => left _
              | right _ => right _
              end
            | right _ => right _
            end
          end
        end
    in
    match t1 with
    | atom a1 =>
      match t2 with
      | atom a2 =>
        match A_eq_dec a1 a2 with
        | left _ => left _
        | right _ => right _
        end
      | _ => right _
      end
    | node l1 =>
      match t2 with
      | atom a2 => right _
      | node l2 =>
        match go_list l1 l2 with
        | left _ => left _
        | right _ => right _
        end
      end
    end); congruence.
  Defined.

  Definition get_atom (t : tree) : option A :=
    match t with
    | atom a => Some a
    | _ => None
    end.
End tree.

Section Forall.
  Variable A : Type.
  Variable P : A -> Prop.

  Inductive Forall : tree A -> Prop :=
  | Forall_atom : forall a, P a -> Forall (atom a)
  | Forall_node : forall l, List.Forall Forall l -> Forall (node l)
  .
End Forall.
Hint Resolve Forall_atom Forall_node.


Require Export state.
Import StateNotations.
Require Export aexp.

From Coq Require Import Bool.Bool.
From Coq Require Import Arith.EqNat. Import Nat.

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Fixpoint beval (st : state) (b : bexp) {struct b} : bool :=
match b with
| BTrue => true
| BFalse => false
| BEq a1 a2 => (aeval st a1) =? (aeval st a2)
| BLe a1 a2 => (aeval st a1) <=? (aeval st a2)
| BNot b1 => negb (beval st b1)
| BAnd b1 b2 => andb (beval st b1) (beval st b2)
end.

Example bexp1 :
    beval ("x" !-> 5) (BAnd BTrue (BNot (BLe (AId "x") (ANum 4)))) = true.
Proof.
  reflexivity.
Qed.

Inductive bevalR : state -> bexp -> bool -> Prop :=
  | E_BTrue (st: state) :
      bevalR st BTrue true
  | E_BFalse (st: state) :
      bevalR st BFalse false
  | E_BEq (st: state) (e1 e2: aexp) (n1 n2 : nat)
      (H1: aevalR st e1 n1)
      (H2: aevalR st e2 n2) :
      bevalR st (BEq e1 e2) (n1 =? n2)
  | E_BLe (st: state) (e1 e2: aexp) (n1 n2 : nat)
    (H1: aevalR st e1 n1)
    (H2: aevalR st e2 n2) :
    bevalR st (BLe e1 e2) (n1 <=? n2)
  | E_BNot (st: state) (e: bexp) (b: bool)
    (H1: bevalR st e b) :
    bevalR st (BNot e) (negb b)
  | E_BAnd (st: state) (e1 e2: bexp) (b1 b2 : bool)
    (H1: bevalR st e1 b1)
    (H2: bevalR st e2 b2) :
    bevalR st (BAnd e1 e2) (andb b1 b2).

Theorem beval_iff_bevalR : forall e b st,
  bevalR st e b <-> beval st e = b.
Proof.
  intros; split.

  - intros; induction H.
    1, 2: reflexivity.
    3, 4: subst; reflexivity.
    all: unfold beval.
    all:
      apply (aeval_iff_aevalR e1 n1) in H1;
      apply (aeval_iff_aevalR e2 n2) in H2.
    all: induction H1; induction H2; reflexivity.

  - generalize dependent b.
    induction e; simpl; intros; subst.
    1, 2: constructor.
    1, 2: constructor; apply aeval_iff_aevalR; reflexivity.
    1: constructor. apply IHe. reflexivity.
    1: constructor.
    apply IHe1. reflexivity.
    apply IHe2. reflexivity.
Qed.

Theorem bev_not_true_iff_false: forall b st,
  beval st b = false <-> beval st (BNot b) = true.
Proof.
  intros. split; intros.
  - unfold beval.
    apply negb_true_iff.
    exact H.
  - unfold beval.
    apply negb_true_iff.
    exact H.
Qed.

Lemma bev_negb_involutive : forall b st,
  beval st (BNot (BNot b)) = beval st b.
Proof.
  intros.
  unfold beval.
  apply negb_involutive.
Qed.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st : state),
    beval st b1 = beval st b2.


Set Implicit Arguments. (* Allows us to use inference for dependent arguments *)

Require Import Reals.   (* Imports real arithmetic. *)
Notation Real := R.        (* Notice: due to the absence of overloading, all       *)
Delimit Scope R_scope   (* numerical constants and operators are nat-typed,     *)
  with Real.               (* unless stated otherwise via the scope delimiter '%'. *)

Check 3 + 4.            (* : ℕ  (nat)  *)
Check (3 + 4) % Real.      (* : ℝ  (Real) *)

Inductive Vec : nat -> Set :=
  VNil : Vec 0
| VCons : forall n, Real -> Vec n -> Vec (S n).

(* Some syntactic sugar *)
Notation "<< x , .. , y >>" := (VCons x .. (VCons y VNil) .. ).

Check << 5, 9, 6 >> .

(* For Q3 + Q4 *)

Fixpoint Vec' n : Set :=
  match n with
    0 => unit
  | S k => Real * Vec' k
  end.


(****************************************************************)
(****************************************************************)
(****                                                        ****)
(****   The data needed for the Kleene fixed-point theorem   ****)
(****                                                        ****)
(****************************************************************)
(****************************************************************)

Module Type KleeneData.
  (*
    Assumption: Let (`T`, `leq`) be a partially ordered set, or poset. A poset
    is a set with a binary relation that is reflexive, transitive, and
    antisymmetric.
  *)

  Parameter T : Type.
  Parameter leq : T -> T -> Prop.

  Axiom reflexivity : forall x, leq x x.
  Axiom transitivity : forall x y z, leq x y -> leq y z -> leq x z.
  Axiom antisymmetry : forall x y, leq x y -> leq y x -> x = y.

  #[export] Hint Resolve reflexivity : main.
  #[export] Hint Resolve transitivity : main.
  #[export] Hint Resolve antisymmetry: main.
  #[export] Hint Rewrite antisymmetry: main.

  (*
    A supremum of a subset of `T` is a least element of `T` which is greater
    than or equal to every element in the subset. This is also called a join or
    least upper bound.
  *)

  Definition supremum P x1 :=
    (forall x2, P x2 -> leq x2 x1) /\
    forall x3, (forall x2, P x2 -> leq x2 x3) -> leq x1 x3.

  #[export] Hint Unfold supremum : main.

  (*
    A directed subset of `T` is a non-empty subset of `T` such that any two
    elements in the subset have an upper bound in the subset.
  *)

  Definition directed P :=
    (exists x1, P x1) /\
    forall x1 x2, P x1 -> P x2 -> exists x3, leq x1 x3 /\ leq x2 x3 /\ P x3.

  #[export] Hint Unfold directed : main.

  (*
    Assumption: Let the partial order be directed-complete. That means every
    directed subset has a supremum.
  *)

  Axiom directedComplete :
    forall P,
    directed P ->
    exists x, supremum P x.

  #[export] Hint Resolve directedComplete : main.

  (*
    Assumption: Let `T` have a least element called bottom. This makes our
    partial order a pointed directed-complete partial order.
  *)

  Parameter bottom : T.

  Axiom bottomLeast : forall x, leq bottom x.

  #[export] Hint Resolve bottomLeast : main.
End KleeneData.