(**
コンピュータの数学 2.6 離散系および連続系の微積分学（和差分学)
======

自然数での下降階乗冪と上昇階乗冪の和分差分の計算 ffact, rfact

2022_08_28 @suharahiromichi
*)
From mathcomp Require Import all_ssreflect.
From common Require Import ssrsumop ssromega.
Require Import Coq.Logic.FunctionalExtensionality.

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

(**
# 和分差分学の定義と補題
 *)
Section FINCAL.
(**
## 短調増加
*)
  Definition monotone a := forall (x : nat), a x <= a x.+1.

(**
## 差分 difference

````
diff b = diff (fun x => b x) = Δb x / Δx = a x
```
を求める。連続系とのアナロジーでは、b は a の原始関数となる。
*)
  Definition diff b := fun x => b x.+1 - b x. (* = a *)

(**
### 差分の公式
 *)
  Lemma diff_split a b (x : nat) :
    monotone a -> monotone b ->
    diff a x + diff b x = diff (fun x => a x + b x) x.
  Proof.
    move=> Ha Hb.
    rewrite /diff.
    rewrite addnBA; last done.
    rewrite subnDA.
    rewrite addnBAC; last done.
    done.
  Qed.

  Lemma diff_distr c b (x : nat) :
    c * diff b x = diff (fun x => c * b x) x.
  Proof.
    rewrite /diff.
    by rewrite mulnBr.
  Qed.

(**
## 和分 summation

### 和分の定義

```Σb(x)δx = Σ(n1 <= k < n2) b(x)```
 *)
  Definition summ b n1 n2 := \sum_(n1 <= x < n2)(b x).

(**
### 差分と和分の関係
*)
(**
差分・和分の基本公式 : 微積分の基本公式のアナロジー (by mh)

Σ a を計算することは a n = b n+1 - b n となる数列 b が既知であれば,
b の差を求めることである。

積分計算とのアナロジーで b を a の原始関数と言ってもよいでしょう ...
```
F'(x) = f(x) のとき ∫ f(x)dx = F(x_max) - F(x_min)
```

総和の場合は、(``diff b = a``)
```
b n+1 - b n = a n のとき Σa = b n+1 - b 0
```
*)
  Lemma summ_diff' b m : b 0 = 0 ->
                         (forall n, b n <= b n.+1) ->
                         summ (diff b) 0 m = b m.
  Proof.
    move=> Hf0 Hfn.
    rewrite /summ /diff.
    elim: m.
    - rewrite sum_nil'.
      by rewrite Hf0.
    - move=> n IHn.
      rewrite sum_last; last done.
      rewrite IHn.
      by rewrite subnKC.
  Qed.

(**
一般に成立するはずの関係
*)
  Lemma summ_diff b n1 n2 : n1 <= n2 -> summ (diff b) n1 n2 = b n2 - b n1.
  Proof.
    rewrite /summ /diff.
  Admitted.                                 (* 不使用 *)

(**
### 和分の公式
 *)
  Lemma summ_nil a n :  summ a n n = 0.
  Proof.
    rewrite /summ.
    by rewrite sum_nil.
  Qed.

  Lemma summ_split a b n1 n2 :
    n1 <= n2 ->
    summ a n1 n2 + summ b n1 n2 = summ (fun x => a x + b x) n1 n2.
  Proof.
    rewrite leq_eqVlt => /orP [Heq | Hlt].
    - move/eqP in Heq.                      (* n1 = n2 の場合 *)
      rewrite -Heq.
      by rewrite 3!summ_nil.
    - rewrite /summ.                        (* n1 < n2 の場合 *)
      by apply: sum_split.
  Qed.

  Lemma summ_distr c a n1 n2 :
    n1 <= n2 -> c * summ a n1 n2 = summ (fun x => c * a x) n1 n2.
  Proof.
    rewrite leq_eqVlt => /orP [Heq | Hlt].
    - move/eqP in Heq.                      (* n1 = n2 の場合 *)
      rewrite -Heq.
      by rewrite 2!summ_nil muln0.
    - by rewrite /summ sum_distrr.
  Qed.

(**
## 一般化した関数拡張の公理

関数の部分だけを取り出して関数拡張する場合、Standard Coq の
functional_extensionality を使うのではだめで、
引数xが m≦x である条件を追加する必要がある。
*)
(*
  Axiom functional_extensionality_ge_m :
    forall (m : nat) (f g : nat -> nat),
      (forall x : nat, m <= x -> f x = g x) -> f = g.
*)
  Axiom functional_extensionality' :
    forall (A B : Type) (P : A -> Prop) (a b : A -> B),
      (forall (x : A), P x -> a x = b x) -> a = b.
  Check fun (m : nat) => @functional_extensionality' nat nat (leq m).

End FINCAL.

(**
# 下降階乗冪 ffact, falling_factorial
 *)
Section FFACT.
(**
## 補題
 *)
  Check ffactn0 : forall n : nat, n ^_ 0 = 1.
  Check ffactn1 : forall n : nat, n ^_ 1 = n.
  Check ffact0n : forall m : nat, 0 ^_ m = (m == 0).
  Lemma  ffact0n' m : 0 < m ->  0 ^_ m = 0.
  Proof. by case: m. Qed.

(**
x^_m が x に対して単調に増加することの証明

``monotone (falling_factorial^~ m)`` という記法は使わないことにします。
*)
  Lemma ffact_monotone m : monotone (fun x => x ^_ m).
  Proof.
    move=> x.
    case: m => // m.                        (* m = 0 の場合を片付ける。 *)
    rewrite ffactSS ffactnSr.               (* m ≧ 1 の場合 *)
    rewrite mulnC leq_mul2r.
    apply/orP/or_intror.
    by ssromega.
  Qed.

(**
## 下降階乗冪の差分

```Δx^_(m + 1) / Δx = (m + 1) * x^_m```
*)
  Lemma diff_ffactE' (m : nat) (x : nat) :
    m <= x -> diff (fun x => x^_m.+1) x = m.+1 * x^_m.
  Proof.
    move=> Hmx.
(*
diff (falling_factorial^~ m.+1) x = m.+1 * x ^_ m
*)
    rewrite /diff.
    rewrite ffactSS ffactnSr [x^_m * (x - m)]mulnC.
    rewrite mulnBl mulSnr.
    rewrite subnBA; last by rewrite leq_mul.
    rewrite -[x * x^_m + x^_m + m * x^_m]addnA.
    rewrite -{2}[x * x^_m]addn0 subnDl subn0.
    rewrite -mulSn.
    done.
  Qed.
(**
``->`` の右のxを抽象して ``=1`` のかたちにすると、
``m <= x``の条件が無視されるため、あとで適用したときに証明が進まなくなる。
*)

(**
より直感的かかたち：

```Δx^_m / Δx = m * x^_(m - 1)```
*)
  Lemma diff_ffactE (m : nat) (x : nat) :
    0 < m -> m <= x -> diff (fun x => x^_m) x = m * x^_m.-1.
  (*                         b                  a *)
  Proof.
    case: m => //=.
    move=> m H0m Hmx.
    rewrite diff_ffactE' //.
    by ssromega.
  Qed.

(**
## 下降階乗冪の和分

下降階乗冪の和分（0から）
x*)
  Lemma summ_ffactE' (m : nat) (n : nat) :
    1 <= m -> m <= n -> summ (fun x => m * x^_m.-1) 0 n = n^_m.
  (*                          a *)
  Proof.
    move=> Hm.                         (* 0^^1 = 1 を回避するため。 *)
    move=> Hmn.
    rewrite -[RHS](@summ_diff' (fun x => x^_m)) //.
    (*                          b *)
    - congr (summ _ 0 n).
      apply: (@functional_extensionality' _ _ (leq m)) => x Hmx.
      by rewrite diff_ffactE.
    - by apply: ffact0n'.
    - move=> x.
      by apply: ffact_monotone.
  Qed.
(**
bigopの関数部分をcongrで取り出し、一般化した関数拡張の公理を使用して証明する。
*)

(**
下降階乗冪の和分（任意のaから）
*)
  Lemma summ_ffactE (m : nat) (n1 n2 : nat) :
    n1 <= n2 -> m < n1 -> summ (fun x => x * x^_m) n1 n2 = n2^_m.+1.
  Proof.
  Admitted.                                 (* 不使用 *)

End FFACT.

(**
# 上昇階乗冪 rfact, rising_factorial

定義およびrfactについての証明は hm 氏による。
 *)
Section RFACT.
  Fixpoint rfact_rec n m := if m is m'.+1 then (n + m') * rfact_rec n m' else 1.
(*
  Fixpoint rfact_rec' n m := if m is m'.+1 then n * rfact_rec' n.+1 m' else 1.
*)
  Definition rising_factorial := nosimpl rfact_rec.

  Notation "n ^^ m" := (rising_factorial n m)
                         (at level 30, right associativity).

  Lemma rfactn0 n : n ^^ 0 = 1. Proof. by []. Qed.

  Lemma rfactn1 n : n ^^ 1 = n.
  Proof.
    rewrite /rising_factorial //=.
    rewrite addn0.
    by rewrite muln1.
  Qed.

  Lemma rfactnSr n m : n ^^ m.+1 = n^^m * (n + m).
  Proof.
    case: m => [|m] //=.
    - have -> : n ^^ 0 = 1 by [].
      rewrite addn0.
      rewrite rfactn1.
      by rewrite mul1n.
    - have -> : n ^^ m.+2 = (n + m.+1) * n ^^ m.+1 by [].
      by rewrite mulnC.
  Qed.

  Lemma rfactnS n m : n ^^ m.+1 = n * n.+1 ^^ m.
  Proof.
    elim: m => [|m IHm].
    - rewrite rfactn1.
      have -> : n.+1 ^^ 0 = 1 by [].
      by rewrite muln1.
    - have -> : n ^^ m.+2 = (n + m.+1) * n ^^ m.+1 by [].
      rewrite IHm.
      rewrite rfactnSr.
      have -> : n + m.+1 = (n+m+1) by ssromega.
      have -> : n.+1 + m = (n+m+1) by ssromega.
      ring.
  Qed.

  Lemma rfactSS n m : n.+1 ^^ m.+1 = n.+1 ^^ m * (n + m.+1).
  Proof.
    rewrite rfactnSr.
    by rewrite addSnnS.
  Qed.

  Lemma rfact0n m : 0 ^^ m = (m == 0).
  Proof.
    case: m => //= m.
    by rewrite rfactnS mul0n.
  Qed.

  Lemma rfact0n' m : 0 < m -> 0 ^^ m = 0.
  Proof.
    case: m => //= m Hm.
    by rewrite rfactnS mul0n.
  Qed.

(**
x^^m が x に対して単調に増加することの証明
*)
  Lemma rfact_monotone m : monotone (fun x => x ^^ m).
  Proof.
    move=> x.
    case: m => // m.                        (* m = 0 の場合を片付ける。 *)
    rewrite rfactSS rfactnS.                (* m ≧ 1 の場合 *)
(*
``x ^_ m * (x - m) <= x.+1 * x ^_ m``
*)
    rewrite mulnDr mulnC.
    by rewrite leq_addr.
  Qed.

(**
## 上昇階乗冪の差分

```Δx^^(m + 1) / Δx = (m + 1) * (x + 1)^^m```
*)
  Lemma diff_rfactE' (m : nat) (x : nat) :
    m <= x -> diff (fun x => x^^m.+1) x = m.+1 * x.+1^^m.
  Proof.
    move=> Hmx.
    rewrite /diff.
    rewrite rfactSS rfactnS.
    rewrite [x.+1 ^^ m * (x + m.+1)]mulnC.
    rewrite mulnDl addnC -addnBA //=.
    by rewrite subnn addn0.
  Qed.

(**
より直感的かかたち：

```Δx^^m / Δx = m * (x + 1)^^(m - 1)```
*)
  Lemma diff_rfactE (m : nat) (x : nat) :
    0 < m -> m <= x -> diff (fun x => x^^m) x = m * x.+1^^m.-1.
  (*                         b                  a *)
  Proof.
    case: m => //=.
    move=> m H0m Hmx.
    rewrite diff_rfactE' //.
    by ssromega.
  Qed.

(**
## 上昇階乗冪の和分

上昇階乗冪の和分（0から）
*)
  Lemma summ_rfactE' (m : nat) (n : nat) :
    1 <= m -> m <= n -> summ (fun x => m * x.+1^^m.-1) 0 n = n^^m.
  (*                          a *)
  Proof.
    move=> Hm.                         (* 0^^1 = 1 を回避するため。 *)
    move=> Hmn.
    Check (@summ_diff' (fun x => x^^m)).
    rewrite -[RHS](@summ_diff' (fun x => x^^m)) //.
    (*                          b *)
    - congr (summ _ 0 n).
      apply: (@functional_extensionality' _ _ (leq m)) => x Hmx.
      by rewrite diff_rfactE.
    - by apply: rfact0n'.
    - move=> x.
      by apply: rfact_monotone.
  Qed.

(**
上昇階乗冪の和分（任意のaから）
*)
  Lemma summ_rfactE (m : nat) (n1 n2 : nat) :
    n1 <= n2 -> m < n1 -> summ (fun x => x * x^^m) n1 n2 = n2^^m.+1.
  Proof.
  Admitted.                                 (* 不使用 *)

End RFACT.

Section OPTION.
(**
# 補足

## 特殊なかたち；

```Δx/Δx = 1```
*)
  Check @diff_ffactE' 0
    : forall x : nat, 0 <= x -> diff (fun x => x^_1) x = 1 * x^_0.

  Lemma diff_idE (x : nat) : diff id x = 1.
  Proof.
    rewrite -[RHS](ffactn0 x) -[RHS]mul1n.
    rewrite -(@diff_ffactE' 0 x); last done.
    rewrite /falling_factorial /ffact_rec.
    rewrite /diff.
    by ssromega.
  Qed.

  Notation "n ^^ m" := (rising_factorial n m)
                         (at level 30, right associativity).

  Check @diff_rfactE' 0
    : forall x : nat, 0 <= x -> diff (fun x => x^^1) x = 1 * x^^0.

  Lemma diff_idE' (x : nat) : diff id x = 1.
  Proof.
    rewrite -[RHS](rfactn0 x) -[RHS]mul1n.
    rewrite -(@diff_rfactE' 0 x); last done.
    rewrite /rising_factorial /rfact_rec.
    rewrite /diff.
    by ssromega.
  Qed.

(**
diff_ffactE' に対応する版
*)
  Lemma summ_ffactE'' (m : nat) (n : nat) :
    1 <= m -> m <= n -> summ (fun x => m.+1 * x^_m) 0 n = n^_m.+1.
  Proof.
    move=> Hm.                         (* 0^_1 = 1 を回避するため。 *)
    move=> Hmn.
    rewrite -[RHS](@summ_diff' (fun x => x^_m.+1)) //.
    - congr (summ _ 0 n).
      apply: (@functional_extensionality' _ _ (leq m)) => x Hmx.
      by rewrite diff_ffactE'.
    - move=> x.
      by apply: ffact_monotone.
  Qed.

(**
diff_rfactE' に対応する版
*)
  Lemma summ_rfactE'' (m : nat) (n : nat) :
    1 <= m -> m <= n -> summ (fun x => m.+1 * x.+1^^m) 0 n = n^^m.+1.
  Proof.
    move=> Hm.                         (* 0^^1 = 1 を回避するため。 *)
    move=> Hmn.
    Check (@summ_diff' (fun x => x^^m)).
    rewrite -[RHS](@summ_diff' (fun x => x^^m.+1)) //.
    - congr (summ _ 0 n).
      apply: (@functional_extensionality' _ _ (leq m)) => x Hmx.
      by rewrite diff_rfactE'.
    - by apply: rfact0n'.
    - move=> x.
      by apply: rfact_monotone.
  Qed.

End OPTION.

(* END *)


Require Import msl.Extensionality.

(* https://en.wikipedia.org/wiki/Lattice_(order) *)

Class Lattice (A: Type) := mkLattice {
  top : A;
  bot : A;
  glb : A -> A -> A;
  lub : A -> A -> A;
  glb_top_r : forall (a: A), glb a top = a;
  lub_bot_r : forall (a: A), lub a bot = a;
  glb_commut : forall (a b: A), glb a b = glb b a;
  lub_commut : forall (a b: A), lub a b = lub b a;
  glb_assoc : forall (a b c: A), glb a (glb b c) = glb (glb a b) c;
  lub_assoc : forall (a b c: A), lub a (lub b c) = lub (lub a b) c;
  glb_absorb : forall (a b: A), glb a (lub a b) = a;
  lub_absorb : forall (a b: A), lub a (glb a b) = a;
}.

Section LatticeFacts.

Context {A: Type}.
Context {LA: Lattice A}.

Lemma glb_idempotent: forall (a: A), glb a a = a.
Proof.
  intros. transitivity (glb a (lub a (glb a a))).
  - f_equal. symmetry. apply lub_absorb.
  - f_equal. apply glb_absorb.
Qed.

Lemma lub_idempotent: forall (a: A), lub a a = a.
Proof.
  intros. transitivity (lub a (glb a (lub a a))).
  - f_equal. symmetry. apply glb_absorb.
  - f_equal. apply lub_absorb.
Qed.

Lemma glb_top_l: forall (a: A), glb top a = a.
Proof. intro. rewrite glb_commut. apply glb_top_r. Qed.

Lemma lub_bot_l: forall (a: A), lub bot a = a.
Proof. intro. rewrite lub_commut. apply lub_bot_r. Qed.

Lemma glb_bot_l: forall (a: A), glb bot a = bot.
Proof.
  intro. transitivity (glb bot (lub bot a)).
  - f_equal. symmetry. apply lub_bot_l.
  - apply glb_absorb.
Qed.

Lemma lub_top_l: forall (a: A), lub top a = top.
Proof.
  intro. transitivity (lub top (glb top a)).
  - f_equal. symmetry. apply glb_top_l.
  - apply lub_absorb.
Qed.

Lemma lub_top_r: forall (a: A), lub a top = top.
Proof. intro. rewrite lub_commut. apply lub_top_l. Qed.

Lemma glb_bot_r : forall (a: A), glb a bot = bot.
Proof. intro. rewrite glb_commut. apply glb_bot_l. Qed.

(* "lattice-lessthan-or-equal" *)
Definition lle(a b: A): Prop := b = lub a b.

Lemma double_lle_eq: forall (a b: A), lle a b -> lle b a -> a = b.
Proof.
  intros a b Le1 Le2. unfold lle in *. rewrite Le1. rewrite lub_commut. apply Le2.
Qed.

Lemma lle_lub_l: forall (a b: A), lle a (lub a b).
Proof.
  intros. unfold lle. rewrite lub_assoc. rewrite lub_idempotent. reflexivity.
Qed.

Lemma lle_lub_r: forall (a b: A), lle b (lub a b).
Proof.
  intros. unfold lle. rewrite lub_commut. rewrite lub_assoc. rewrite lub_idempotent. reflexivity.
Qed.

Lemma lle_bot_inv: forall (a: A), lle a bot -> a = bot.
Proof. intros. unfold lle in *. rewrite H. symmetry. apply lub_bot_r. Qed.

Lemma lub_bot_inv: forall (a b: A), lub a b = bot -> a = bot /\ b = bot.
Proof.
  intros.
  pose proof (lle_lub_l a b) as C. rewrite H in C. apply lle_bot_inv in C.
  pose proof (lle_lub_r a b) as D. rewrite H in D. apply lle_bot_inv in D.
  apply (conj C D).
Qed.

Lemma lle_top: forall (a: A), lle a top.
Proof. intro. unfold lle. symmetry. apply lub_top_r. Qed.

Lemma lle_refl: forall (a: A), lle a a.
Proof. intro. unfold lle. symmetry. apply lub_idempotent. Qed.

End LatticeFacts.

Inductive label : Set := Lo | Hi.

Instance LoHi : Lattice label := {|
  top := Hi;
  bot := Lo;
  glb := fun l1 l2 => match l1 with
         | Hi => l2
         | Lo => Lo
         end;
  lub := fun l1 l2 => match l1 with
         | Lo => l2
         | Hi => Hi
         end
|}.
- intro a. destruct a; reflexivity.
- intro a. destruct a; reflexivity.
- intros a b. destruct a; destruct b; reflexivity.
- intros a b. destruct a; destruct b; reflexivity.
- intros a b c. destruct a; destruct b; destruct c; reflexivity.
- intros a b c. destruct a; destruct b; destruct c; reflexivity.
- intros a b. destruct a; destruct b; reflexivity.
- intros a b. destruct a; destruct b; reflexivity.
Defined.

Instance LiftLattice {T A: Type} (LA: Lattice A): Lattice (T -> A) := {|
  top := fun (x: T) => (@top A LA);
  bot := fun (x: T) => (@bot A LA);
  glb := fun (a b: T -> A) => (fun (x: T) => @glb A LA (a x) (b x));
  lub := fun (a b: T -> A) => (fun (x: T) => @lub A LA (a x) (b x));
|}.
- intro. extensionality. apply glb_top_r.
- intro. extensionality. apply lub_bot_r.
- intros. extensionality. apply glb_commut.
- intros. extensionality. apply lub_commut.
- intros. extensionality. apply glb_assoc.
- intros. extensionality. apply lub_assoc.
- intros. extensionality. apply glb_absorb.
- intros. extensionality. apply lub_absorb.
Defined.

(* Now we have lub and glb available for any number of lifting levels:

Check (glb (fun (i: nat) => Hi) (fun (i: nat) => Lo)).
Check (glb (fun (x: nat) (i: nat*nat) => Hi) (fun (x: nat) (i: nat*nat) => Lo)).
Eval simpl in (lub (fun (x: nat) (i: nat*nat) => Hi) (fun (x: nat) (i: nat*nat) => Lo)).
Eval simpl in (lub (fun (x: nat) (i: nat*nat) => Lo) (fun (x: nat) (i: nat*nat) => Lo)).

Including all the lemmas!
*)

Section LiftLatticeFacts.

Context {T: Type}.
Context {A: Type}.
Context {LA: Lattice A}.

Lemma lle_pointwise: forall (f1 f2: T -> A), lle f1 f2 <-> forall (x: T), lle (f1 x) (f2 x).
Proof.
  split.
  - intros. unfold lle in *. pose proof (equal_f H) as C. apply C.
  - intro. unfold lle in *. extensionality. apply H.
Qed.

End LiftLatticeFacts.

(* Basically just a lattice on A, but with an additional element "None" sitting on top
   of the whole lattice.
   We chose to put "None" at the top because it means absence of classification information,
   in which case we have to assume that it is classified as Hi, which is top. *)
Instance OptionLattice {A: Type} (LA: Lattice A): Lattice (option A) := {|
  top := (@None A);
  bot := Some (@bot A LA);
  glb := fun (oa ob: option A) => match oa, ob with
         | None  , None   => None
         | Some a, None   => Some a
         | None  , Some b => Some b
         | Some a, Some b => Some (@glb A LA a b)
         end;
  lub := fun (oa ob: option A) => match oa, ob with
         | Some a, Some b => Some (@lub A LA a b)
         | _, _ => None
         end;
|}.
- intro a. destruct a; reflexivity.
- intro a. destruct a; try reflexivity. f_equal. apply lub_bot_r.
- intros a b. destruct a; destruct b; try reflexivity. f_equal. apply glb_commut.
- intros a b. destruct a; destruct b; try reflexivity. f_equal. apply lub_commut.
- intros a b c. destruct a; destruct b; destruct c; try reflexivity. f_equal. apply glb_assoc.
- intros a b c. destruct a; destruct b; destruct c; try reflexivity. f_equal. apply lub_assoc.
- intros a b. destruct a; destruct b; try reflexivity. f_equal. apply glb_absorb.
- intros a b. destruct a; destruct b; try reflexivity; f_equal.
  + apply lub_absorb.
  + apply lub_idempotent.
Defined.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export ZArithRing.
Require Import Relations.

(** Example of use of the conversion rule
*)
Theorem conv_example : forall n:nat, 7*5 < n -> 6*6 <= n.
Proof.
 intros; assumption.
Qed.

Theorem imp_trans : forall P Q R:Prop, (P->Q)->(Q->R)->P->R.
Proof.
  intros P Q R H H0 p.
  apply H0; apply H; assumption.
Qed.

(** Tests :

Print imp_trans.

Check (imp_trans _ _ _ (le_S 0 1)(le_S 0 2)).

*)

Definition neutral_left (A:Type)(op:A->A->A)(e:A) : Prop :=
  forall x:A, op e x = x.

Lemma one_neutral_left : neutral_left Z Zmult 1%Z.
Proof.
 intro z; ring.
Qed.

Lemma le_i_SSi : forall i:nat, i <= S (S i).
Proof.
 intro i.
 do 2 apply le_S; apply le_n.
Qed.

Lemma all_imp_dist   :
 forall (A:Type)(P Q:A->Prop),
         (forall x:A, P x -> Q x)->
         (forall y:A, P y)->
          forall z:A, Q z.
Proof.
 intros A P Q H H0 z.
 apply H; apply H0; assumption.
Qed.

Lemma mult_le_compat_r : forall m n p:nat, le n p -> le (n * m) (p * m).
Proof.
 intros m n p H; rewrite (mult_comm n m); rewrite (mult_comm p m).
 apply mult_le_compat_l; trivial.
Qed.

Lemma le_mult_mult :
   forall a b c d:nat, a <= c -> b <= d -> a * b <= c * d.
Proof.
 intros a b c d H H0.
 apply le_trans with (m := c  *b).
 - apply mult_le_compat_r; assumption.
 - apply mult_le_compat_l; assumption.
Qed.

(** using eapply ...
*)

Lemma le_mult_mult' :
 forall a b c d:nat, a <= c -> b <= d -> a*b <= c*d.
Proof.
 intros a b c d H H0.
 eapply le_trans.
 - eapply mult_le_compat_l.
   eexact H0.
 -  now apply mult_le_compat_r.
Qed.

Lemma le_O_mult : forall n p:nat, 0 * n <= 0 * p.
Proof.
 intros n p; apply le_n.
Qed.

Lemma lt_8_9 : 8 < 9.
Proof.
 unfold lt; apply le_n.
Qed.

(** Tests :

SearchPattern (_ + _ <= _)%Z.

SearchPattern (?X1 * _ <= ?X1 * _)%Z.

*)

Lemma lt_S : forall n p:nat, n < p -> n < S p.
Proof.
 intros n p H.
 unfold lt; apply le_S; trivial.
Qed.

Open Scope Z_scope.

Definition Zsquare_diff (x y:Z):= x * x - y * y.

Theorem unfold_example :
 forall x y:Z,
   x*x = y*y ->
   Zsquare_diff x y * Zsquare_diff (x+y)(x*y) = 0.
Proof.
 intros x y Heq.
 unfold Zsquare_diff at 1.
 rewrite Heq; ring.
Qed.

Section ex_falso_quodlibet.
 Hypothesis ff : False.

 Lemma ex1 : 220 = 284.
 Proof.
   apply False_ind.
   exact ff.
 Qed.

 Lemma ex2 : 220 = 284.
 Proof.
  destruct ff.
 Qed.

End ex_falso_quodlibet.

Theorem absurd : forall P Q:Prop, P -> ~P -> Q.
Proof.
 intros P Q p H.
 elim H.
 assumption.
Qed.

Theorem double_neg_i : forall P:Prop, P->~~P.
Proof.
 intros P p H.
 apply H; assumption.
Qed.

Theorem modus_ponens :forall P Q:Prop, P->(P->Q)->Q.
Proof.
 auto.
Qed.

Theorem double_neg_i' : forall P:Prop, P -> ~ ~ P.
Proof.
 intro P; exact (modus_ponens P False).
Qed.

Theorem contrap :forall A B:Prop, (A->B) -> ~B -> ~A.
Proof.
 intros A B; unfold not.
 apply imp_trans.
Qed.

Theorem disj4_3' : forall P Q R S:Prop, R -> P \/ Q \/ R \/ S.
Proof.
  right; right; left; assumption.
Qed.

Lemma and_commutes : forall A B:Prop, A /\ B -> B /\ A.
Proof.
 intros A B H; destruct H.
 split; assumption.
Qed.

Lemma or_commutes : forall A B:Prop, A\/B->B\/A.
Proof.
 intros A B H; destruct H as [H | H]; auto.
Qed.

Lemma ex_imp_ex :
 forall (A:Type)(P Q:A->Prop), (ex P)->(forall x:A, P x -> Q x)->(ex Q).
Proof.
 intros A P Q H H0; destruct H as [a Ha].
 exists a; apply H0; assumption.
Qed.

Lemma L36 : 6 * 6 =9 * 4.
Proof. reflexivity. Qed.

Lemma diff_of_squares : forall a b:Z, ((a + b) * (a - b) = a * a - b * b)%Z.
Proof.
 intros; ring.
Qed.

Theorem eq_sym' : forall (A:Type)(a b:A), a = b -> b = a.
Proof.
 intros A a b e; rewrite e; reflexivity.
Qed.

Lemma Zmult_distr_1 : forall n x:Z, n * x + x = ( n + 1) * x.
Proof.
 intros n x ; rewrite Zmult_plus_distr_l.
 now rewrite  Zmult_1_l.
Qed.

Lemma regroup : forall x:Z, x + x + x + x + x = 5 * x.
Proof.
 intro x; pattern x at 1.
 rewrite <- Zmult_1_l.
 repeat rewrite Zmult_distr_1.
 reflexivity.
Qed.

Open Scope nat_scope.

Theorem le_lt_S_eq : forall n p:nat, n <= p -> p < S n -> n = p.
Proof.
 intros; omega.
Qed.

Lemma conditional_rewrite_example : forall n:nat,
   8 < n + 6 ->  3 + n < 6 -> n * n = n + n.
Proof.
 intros n  H H0.
 rewrite <- (le_lt_S_eq 2 n).
 - reflexivity.
 -  apply  plus_le_reg_l with (p := 6).
    rewrite plus_comm in H; auto with arith.
 - apply   plus_lt_reg_l with (p:= 3); auto with arith.
Qed.

(** A shorter proof ...
*)

Lemma conditional_rewrite_example' : forall n:nat,
   8 < n + 6 ->  3 + n < 6 -> n * n = n + n.
Proof.
 intros n  H H0.
 assert (n = 2) by omega.
 now subst n.
Qed.

Theorem eq_trans :
   forall (A:Type)(x y z:A), x = y -> y = z -> x = z.
Proof.
 intros A x y z H; rewrite H; auto.
Qed.

Definition my_True : Prop
:= forall P:Prop, P -> P.

Definition my_False : Prop
:= forall P:Prop, P.

Theorem my_I : my_True.
Proof.
 intros P p; assumption.
Qed.

Theorem my_False_ind : forall P:Prop, my_False->P.
Proof.
 intros P F; apply F.
Qed.

Definition my_not (P:Prop) : Prop := P->my_False.

Section leibniz.

 Variable A : Type.

 Definition leibniz (a b:A) : Prop :=
 forall P:A -> Prop, P a -> P b.

Theorem leibniz_sym : symmetric A leibniz.
Proof.
 intros x y H Q; apply H; trivial.
Qed.

End leibniz.

Definition my_and (P Q:Prop) :=
  forall R:Prop, (P->Q->R)->R.

Definition my_or (P Q:Prop) :=
  forall R:Prop, (P->R)->(Q->R)->R.

Definition my_ex (A:Type)(P:A->Prop) :=
  forall R:Prop, (forall x:A, P x -> R)->R.

Definition my_le (n p:nat) :=
  forall P:nat -> Prop, P n ->(forall q:nat, P q -> P (S q))-> P p.


Require Export stlc.Maps.

Inductive type : Type :=
  | tvar : string -> type
  | tarr : type -> type -> type
  | tprod : type -> type -> type.

Inductive term : Type :=
  | var : string -> term
  | app : term -> term -> term
  | lam : string -> type -> term -> term
  | prod : term -> term -> term
  | fst : term -> term
  | snd : term -> term.

Definition ctx := partial_map type.

(* Exercise 2.1 *)

Definition X_Y_X (X:string) (Y:string) : type :=
  tarr (tvar X) (tarr (tvar Y) (tvar X)).

Definition XX_XX (X:string) : type :=
  tarr (tarr (tvar X) (tvar X)) (tarr (tvar X) (tvar X)).

(* Exercise 2.2 *)

Definition lxly_x (X:string) (Y:string) : term :=
  lam "x" (tvar X) (lam "y" (tvar Y) (var "x")).

Definition lflx_ffx (X:string) : term :=
  lam "f" (tarr (tvar X) (tvar X))
      (lam  "x" (tvar X)
            (app  (var "f")
                  (app  (var "f")
                        (var "x")))).

(* Exercise 2.3 *)

Inductive typed : ctx -> term -> type -> Prop :=
  | var_typed : forall E x A,
      E x = Some A ->
      typed E (var x) A
  | app_typed : forall A B E M N,
      typed E M (tarr A B) ->
      typed E N A ->
      typed E (app M N) B
  | lam_typed : forall E x A B M,
      typed (update E x A) M B ->
      typed E (lam x A M) (tarr A B)
  | prod_typed : forall E t s T S,
      typed E t T ->
      typed E s S ->
      typed E (prod t s) (tprod T S)
  | fst_typed : forall E p T S,
      typed E p (tprod T S) ->
      typed E (fst p) T
  | snd_typed : forall E p T S,
      typed E p (tprod T S) ->
      typed E (snd p) S.

(* Exercise 2.4 *)

Lemma test : typed  empty
                    (lxly_x "X" "Y")
                    (X_Y_X "X" "Y").
Proof.
  unfold lxly_x. unfold X_Y_X.
  apply lam_typed.
  apply lam_typed.
  apply var_typed.
  reflexivity.
Qed.

(* Exercise 2.5 *)

(*  To build a typechecker, we first need to define
    a helper function for type equality and prove that
    it actually defines equality. *)
Fixpoint beq_type (A B:type) : bool :=
  match A,B with
  | tvar a, tvar b => beq_string a b
  | tarr A1 B1, tarr A2 B2 =>
      andb (beq_type A1 A2) (beq_type B1 B2)
  | tprod T1 S1, tprod T2 S2 =>
      andb (beq_type T1 T2) (beq_type S1 S2)
  | _,_ =>
      false
  end.

Lemma beq_type_refl : forall A,
  beq_type A A = true.
Proof.
  intros A1. induction A1; simpl.
  apply beq_string_true_iff. reflexivity.
  rewrite IHA1_1. rewrite IHA1_2. reflexivity.
  rewrite IHA1_1. rewrite IHA1_2. reflexivity. Qed.

Lemma beq_type_eq : forall A B,
  beq_type A B = true -> A = B.
Proof.
  intros A. induction A; intros A Hbeq; destruct A; inversion Hbeq.
  - apply beq_string_true_iff in H0. rewrite H0. reflexivity.
  - apply andb_prop in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHA1 in Hbeq1. apply IHA2 in Hbeq2. subst... reflexivity.
  - apply andb_prop in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHA1 in Hbeq1. apply IHA2 in Hbeq2. subst... reflexivity.
Qed.

Fixpoint typecheck (E:ctx) (t:term) : option type :=
  match t with
  | var x =>
      E x
  | app M N =>
      match typecheck E M, typecheck E N with
      | Some (tarr A B),Some A1 =>
          if beq_type A A1 then Some B else None
      | _,_ => None
      end
  | lam x A M =>
      match typecheck (update E x A) M with
      | Some B => Some (tarr A B)
      | _ => None
      end
  | prod s t =>
      match typecheck E s, typecheck E t with
      | Some A, Some B => Some (tprod A B)
      | _,_ => None
      end
  | fst p =>
      match typecheck E p with
      | Some (tprod A B) => Some A
      | _ => None
      end
  | snd p =>
      match typecheck E p with
      | Some (tprod A B) => Some B
      | _ => None
      end
  end.

(* Exercise 2.6 *)

(*
The typing judgement [typed] will tell us for a given
context, term and type whether the term is of that type.
The type checker [typecheck] will tell us for a given
context and term what the type is (or it will return
nothing if there is no type).
 *)

(* Exercise 2.7 *)

Example pos_typecheck_1 :
  typecheck empty (lxly_x "X" "Y") = Some (X_Y_X "X" "Y").
Proof. reflexivity. Qed.

Example pos_typecheck_2 :
typecheck empty (lflx_ffx "X") = Some (XX_XX "X").
Proof. reflexivity. Qed.

Definition lx_xx (X: string) :=
  lam "x" (tvar X) (app (var "x") (var "x")).

Example neg_typecheck_1 :
typecheck empty (lx_xx "X") = None.
Proof. reflexivity. Qed.

Definition lflx_xf (X: string) :=
  lam "f" (tarr (tvar X) (tvar X))
      (lam "x" (tvar X)
           (app (var "x") (var "f")) ).

Example neg_typecheck_2 :
typecheck empty (lflx_xf "X") = None.
Proof. reflexivity. Qed.

(* Exercise 2.8 *)

Lemma typecheck_complete : forall E t A,
  typed E t A ->
  typecheck E t = Some A.
Proof.
  intros E t A H.
  induction H.
  - apply H.
  - simpl.
    rewrite IHtyped1. rewrite IHtyped2.
    rewrite beq_type_refl.
    reflexivity.
  - simpl.
    rewrite IHtyped. reflexivity.
  - simpl.
    rewrite IHtyped1. rewrite IHtyped2.
    reflexivity.
  - simpl.
    rewrite IHtyped. reflexivity.
  - simpl.
    rewrite IHtyped. reflexivity.
Qed.

Lemma typecheck_sound : forall E t A,
  typecheck E t = Some A -> typed E t A.
Proof.
  intros E t. generalize dependent E.
  induction t; intros E T Htc; inversion Htc.
  - apply var_typed. apply H0.
  - remember (typecheck E t1) as TO1.
    remember (typecheck E t2) as TO2.
    destruct TO1 as [A|]; inversion H0;
    destruct A as [|A1 A2|T1 S1]; inversion H0.
    destruct TO2 as [B|]; inversion H0.
    remember (beq_type A1 B) as b.
    destruct b; inversion H0.
    symmetry in Heqb. apply beq_type_eq in Heqb.
    inversion H0; subst...
    apply app_typed with (A := B) (B := T).
    symmetry in HeqTO1.
    apply IHt1 in HeqTO1. apply HeqTO1.
    symmetry in HeqTO2.
    apply IHt2 in HeqTO2. apply HeqTO2.
  - remember (update E s t) as G'.
    remember (typecheck G' t0) as TO2.
    destruct TO2; inversion H0.
    inversion H0. apply lam_typed. rewrite <- HeqG'.
    apply IHt. rewrite HeqTO2. reflexivity.
  - remember (typecheck E t1) as TO1.
    remember (typecheck E t2) as TO2.
    destruct TO1; inversion H0.
    destruct TO2; inversion H0.
    apply prod_typed.
    symmetry in HeqTO1. apply IHt1 in HeqTO1.
    apply HeqTO1.
    symmetry in HeqTO2. apply IHt2 in HeqTO2.
    apply HeqTO2.
  - remember (typecheck E t) as TO1.
    destruct TO1; inversion H0.
    destruct t0; inversion H0.
    symmetry in HeqTO1.
    apply IHt in HeqTO1.
    rewrite -> H2 in HeqTO1.
    apply fst_typed with (S := t0_2).
    apply HeqTO1.
  - remember (typecheck E t) as TO1.
    destruct TO1; inversion H0.
    destruct t0; inversion H0.
    symmetry in HeqTO1.
    apply IHt in HeqTO1.
    rewrite -> H2 in HeqTO1.
    apply snd_typed with (T := t0_1).
    apply HeqTO1.
Qed.

(*
Inductive typed : ctx -> term -> type -> Prop :=
  | var_typed : forall E x A,
      E x = Some A ->
      typed E (var x) A
  | app_typed : forall A B E M N,
      typed E M (tarr A B) ->
      typed E N A ->
      typed E (app M N) B
  | lam_typed : forall E x A B M,
      typed (update E x A) M B ->
      typed E (lam x A M) (tarr A B)
  | prod_typed : forall E t s T S,
      typed E t T ->
      typed E s S ->
      typed E (prod t s) (tprod T S)
  | fst_typed : forall E p T S,
      typed E p (tprod T S) ->
      typed E (fst p) T
  | snd_typed : forall E p T S,
      typed E p (tprod T S) ->
      typed E (snd p) S.

*)


Require Import Nat.
Require Import Arith.

(* Função Somatório *)
Fixpoint somat (n:nat) : nat :=
 match n with
  | 0 => 0
  | S m => n + (somat m)
end.

(*
  Search (( _ + _) * (_ + _)).

  A + B = B + A

  (S n) + (plus (S n) m = (plus (S n) + m + (S n)
*)

Lemma dois_div :
  forall (n m:nat), (n + (div2 m)) = (div2 (n + (n + m))).
Proof.
intros.
induction n.

(* Caso Base *)
 - simpl.
   reflexivity.

(* Caso indutivo *)
 - simpl. (* tira 1 da divisão *)
   rewrite (Nat.add_comm n (S (n + m))). (* coloca sucessor na direita para poder retornar à divisão *)
   simpl.
   rewrite IHn. (* rescrever n + div2 m *)
   rewrite (Nat.add_comm n (n  + m)). (* alterar a ordem para reflexividade *)
   reflexivity.
Qed.

Lemma somat_aux :
forall (n:nat), (plus n (somat n)) = (div2 (plus n (plus n (plus n (mult n n))))).
Proof.
induction n.

(* Caso Base *)
 - simpl.
   reflexivity.

(* Caso Indutivo *)
 - simpl. (* tira 1 da divisão *)
    + rewrite <- (Nat.add_comm (S (n + S (n + S (n + n * S n)))) n). (* Remover os sucessores de dentro da divisão *)
      rewrite <- (Nat.add_comm (S (n + S (n + n * S n))) n).
      rewrite <- (Nat.add_comm (S (n + n * S n)) n).
      rewrite <- (Nat.add_comm (n * S n) n).
      rewrite <- (Nat.mul_comm (S n) n).
      simpl. (* Volta a por a divisão e retira os S *)

    * rewrite -> IHn. (* O que queremos igualar *)
      rewrite <- (Nat.add_comm (S (div2 (n + (n + (n + n * n))))) n). (* Troca para por o n dentro do S *)
      simpl.
      rewrite <- (Nat.add_comm  n (div2 (n + (n + (n + n * n))))). (* Troca para usar o dois div*)
      rewrite -> (dois_div n (n + (n + (n + n * n)))).
      rewrite <- (Nat.add_comm  (n + (n + (n + (n + n * n)))) n). (* Trocas para deixar ambos os termos iguais *)
      rewrite <- (Nat.add_comm  (n + (n + (n + n * n))) n).
      rewrite <- (Nat.add_comm  (n + n * n) n).
      rewrite <- (Nat.add_comm  (n + n * n + n) n).
      reflexivity.
Qed.

Lemma somat_correct: forall (n:nat), (somat n) = (div2 (mult n (S n))).
Proof.
(* Caso Base *)
intro.
induction n.
 - simpl.
   reflexivity.

(* Caso Indutivo *)
 - simpl.
    + rewrite <- (Nat.mul_comm (S (S n)) n).
      rewrite <- (Nat.add_comm (S (S n) * n) n).
      simpl.

    * rewrite -> (somat_aux n).
      rewrite <- (Nat.add_comm (n + n * n) n).
      rewrite <- (Nat.add_comm (n + n * n + n) n).
      reflexivity.
Qed.


(** * 2018 Functional Programming Homework1 *)

(*
    10152160137
    陈弈君
*)

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

(* 1. Prove the following properties.*)

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

Theorem mult_Sn : forall n m : nat, (1 + n) * m = m + n * m.

Proof.
  intros n m. simpl. reflexivity. Qed.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Theorem exp_1_l: forall n : nat, exp n 1 = n * 1.

Proof.
  intros n. simpl. reflexivity. Qed.

Theorem exp_Sn : forall n m : nat, exp n (1+m) = n * (exp n  m).
Proof.
  intros n m. simpl. reflexivity. Qed.

(* 2. Define the geb function that tests whether its first argument is greater than or equal to its second argument, yielding a boolean. *)

Fixpoint geb(n1 n2 : nat) : bool :=
  match n2 with
  | 0 => true
  | S n2' =>
    match n1 with
    | 0 => false
    | S n1' => geb n1' n2'
    end
  end.

Example test_geb1 : (geb 4 4) = true.

Proof. simpl. reflexivity. Qed.

Example test_geb2 : (geb 4 6) = false.

Proof. simpl. reflexivity. Qed.

Example test_geb3 : (geb 7 5) = true.

Proof. simpl. reflexivity. Qed.

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

Proof. intros n. simpl. reflexivity. Qed.


Add LoadPath "/Users/danielle/projects/software-foundations/chapter02/".

Require Import basics.

Definition blt_nat (n m : nat) : bool :=
  negb (ble_nat m n).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. reflexivity. Qed.


(*
Verificación Formal - 2020-II
Archivo de definiciones - Arreglos flexibles usando árboles de Braun

Importación de los archivos de definiciones y propiedades de BN
*)
From TAREA3 Require Import Defs_BN.
From TAREA3 Require Import Props_BN.

(*
------------------------------------####------------------------------------
------------------------------------####------------------------------------
                Inicio del Fragmento de código visto en clase.
------------------------------------####------------------------------------
------------------------------------####------------------------------------
*)

(*
Definition of binary trees and some of their properties
*)
Parameter (A:Type)
          (eq_dec_A: forall (x y:A),{x=y}+{x<>y})
          (undefA : A).

(*
Binary trees defined here
*)
Inductive BTree : Type :=
  | E : BTree
  | N : A -> BTree  -> BTree  -> BTree.

Check BTree_ind.

(*
Árbol indefinido
*)
Parameter (undefBTree : BTree).

(*
size on binary trees defined next
*)
Fixpoint bsize (t:BTree): BN :=
match t with
  | E => Z
  | N x s t =>  sucBN ((bsize s) ⊞ (bsize t))
end.

Check bsize.

(*
Balance condition on Braun trees
*)
Inductive bbal : BTree -> Prop:=
  | bbalE : bbal E
  | bbalN : forall (a: A) (s t: BTree),
            bbal s -> bbal t -> (bsize t) ≤BN (bsize s) ->
            (bsize s) ≤BN (sucBN (bsize t)) ->
            bbal (N a s t).

Check bbal_ind.

Parameter (allBal: forall (t:BTree), bbal t).

(*
Consulta del elemento b-simo
*)
Fixpoint lookup_bn (t:BTree) (b: BN) : A :=
match t,b with
  | E, b => undefA
  | N x s t,Z => x
  | N x s t, U a => lookup_bn s a   (* U a = 2a+1 *)
  | N x s t, D a => lookup_bn t a   (* D a = 2a + 2 *)
end.

(*
Actualización del elemento b-simo
*)
Fixpoint update (t:BTree) (b: BN) (x : A) : BTree :=
match t,b with
  | E, b => undefBTree
  | N y s t, Z =>  N x s t
  | N y s t, U a => N y (update s a x) t
  | N y s t, D a => N y s (update t a x)
end.

(*
Inserción de un elento al inicio del arreglo
*)
Fixpoint le (x:A) (t:BTree) : BTree :=
match t with
  | E => N x E E
  | N y s t => N x (le y t) s
end.

(*
Inserción de un elento al final del arreglo
*)
Fixpoint he (x:A) (t:BTree) : BTree  :=
match t with
  | E => N x E E
  | N y l r => match bsize t with
                | Z => undefBTree
                | U b => N y (he x l) r
                | D b => N y l (he x r)
              end
end.

(*
------------------------------------####------------------------------------
------------------------------------####------------------------------------
                   Fin del fragmento de código visto en clase.
------------------------------------####------------------------------------
------------------------------------####------------------------------------
*)

(*
------------------------------------####------------------------------------
------------------------------------####------------------------------------
                Inicio del fragmento de código implementado.
------------------------------------####------------------------------------
------------------------------------####------------------------------------
*)

(*
Eliminación del primer elemento en el arreglo
*)
Fixpoint lr (t:BTree) : BTree  :=
match t with
  | E => undefBTree
  | N y l r => match l with
                | E => E
                | N x _ _ => N x r (lr l)
               end
end.

(*
Eliminación del últiom elemento en el arreglo
*)
Fixpoint hr (t:BTree) : BTree  :=
match t with
  | E => undefBTree
  | N y E _ => E
  | N y l r => match bsize t with
                | U b => N y l (hr r)
                | D b => N y (hr l) r
                | Z => undefBTree
               end
end.


Require Import Ordinal.

(* 一些比较弱的著名记号，主要从大数入门.pdf中选取 *)

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

Compute (List fac 5).

(* 乘方 *)
Fixpoint pow(a b:nat) :=
match b with
| O => 1
| S b' => a*(pow a b')
end.

Compute (List (pow 2) 5).
Compute (List (pow 3) 5).

(* 阿克曼函数 *)
Fixpoint Ack(m:nat):nat->nat :=
match m with
| O => S
| S m' => fun n=>iter (Ack m') n (Ack m' 1)
end.

Compute (List (Ack 0) 4).
Compute (List (Ack 1) 4).
Compute (List (Ack 2) 4).
Compute (List (Ack 3) 4).
Compute (List (Ack 4) 0).

(* 高德纳箭头 *)
Fixpoint arrow(a n b:nat) :=
match n with
| O => O
| S O => pow a b
| S n' => iter (arrow a n') (b-1) a
end.

Compute (List (arrow 2 1) 4).
Compute (List (arrow 2 2) 4).

(* 葛立恒数 *)
Fixpoint G(n:nat) :=
match n with
| O => 4
| S n' => arrow (G n') 3 3
end.

Definition G64 := G 64.

(* 康威链 *)
(**
  a,b = a^b
  X,1,Y = X
  X,a+1,b+1 = X,(X,a,b+1),b
  大写字母表示自然数构成的序列，小写字母表示自然数
**)

(* 可以从 F0=X 和 F1(a)=X,a 构造 chain_suc(F0,F1,a,b)=X,a,b *)
Fixpoint chain_suc(F0:nat)(F1:nat->nat)(a b:nat):nat :=
match a,b with
| 1,_ => F0
| _,1 => F1 a
| (S a'),(S b') => iter (fun x=>chain_suc F0 F1 x b') a' F0
| _,_ => O
end.

(* 根据 F0=X、F1(a)=X,a、ls=Y 递归计算 X,a,Y *)
Fixpoint chain' (F0:nat)(F1:nat->nat)(ls:list nat):nat :=
match ls with
| nil => F0
| cons a b =>
  match b with
  | nil => F1 a
  | _ => chain' (F1 a) (chain_suc F0 F1 a) b
  end
end.

(* 计算康威链 *)
Definition chain(ls:list nat) :=
match ls with
| nil => 1
| cons a bs => chain' a (pow a) bs
end.

Compute (chain (17::nil)).
Compute (chain (2::3::nil)).
Compute (chain (3::2::nil)).
Compute (chain (2::3::2::nil)).
Compute (arrow 2 2 3).

(* 将a重复b次的列表 *)
Fixpoint repeat_list(a b:nat): list nat :=
match b with
| O => nil
| S b' => cons a (repeat_list a b')
end.

(* 康威链的下标扩展 *)
Fixpoint chain_ex(n:nat)(ls:list nat):nat :=
match ls with
| nil => 1
| cons a bs =>
  match n with
  | 0 => O
  | 1 => chain' a (pow a) bs
  | S n' => chain' a (fun b=>chain_ex n' (repeat_list a (S b))) bs
  end
end.

Goal chain_ex 1 = chain.
split.
Qed.


Require Import ZArith.
Require Import VCF.Sem.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import VCF.BinRelDomain.
Require Import VCF.KnasterTarski.
Require Import VCF.WhileLang.

Definition state := var -> Z.
Definition constant_func {A: Type} (c: Z): A -> Z := fun _ => c.
Definition query_var (X: var): state -> Z := fun st => st X.

Fixpoint aeval (a : aexp) : state -> Z :=
  match a with
  | ANum n => constant_func n
  | AId X => query_var X
  | APlus a1 a2 => (aeval a1 + aeval a2)%Func
  | AMinus a1 a2  => (aeval a1 - aeval a2)%Func
  | AMult a1 a2 => (aeval a1 * aeval a2)%Func
  end.

Fixpoint beval (b : bexp) : state -> Prop :=
  match b with
  | BTrue       => Sets.full
  | BFalse      => Sets.empty
  | BEq a1 a2   => ZFunc.test_eq (aeval a1) (aeval a2)
  | BLe a1 a2   => ZFunc.test_le (aeval a1) (aeval a2)
  | BNot b1     => Sets.complement (beval b1)
  | BAnd b1 b2  => Sets.intersect (beval b1 ) (beval b2)
  end.

Definition if_sem
  (cond: state -> Prop)
  (then_branch else_branch: state -> state -> Prop)
  : state -> state -> Prop
:=
  Sets.union
    (Rel.concat (Rel.test cond) then_branch)
    (Rel.concat (Rel.test (Sets.complement cond)) else_branch).

Definition loop_sem_CL:
  @CompleteLattice_Setoid
    (state -> state -> Prop)
    Sets.included
    Sets.equiv
    Sets.omega_union
:= SETS_included_CL.

Local Existing Instance loop_sem_CL.

Definition loop_sem (cond: state -> Prop) (loop_body: state -> state -> Prop):
  state -> state -> Prop :=
  KT_fix_l
    (fun sem =>
       Sets.union
         (Rel.concat
           (Rel.test cond)
           (Rel.concat loop_body sem))
         (Rel.test (Sets.complement cond))).

Lemma loop_sem_recur:
  forall cond loop_body,
    Sets.equiv
      (loop_sem cond loop_body)
      (Sets.union
         (Rel.concat
           (Rel.test cond)
           (Rel.concat loop_body (loop_sem cond loop_body)))
         (Rel.test (Sets.complement cond))).
Proof.
  intros.
  unfold loop_sem.
  match goal with
  | |- Sets.equiv (KT_fix_l ?F) _ =>
    pose proof KnasterTarski_fixpoint_theorem_l F as H; apply H; clear H
  end.
  hnf; intros.
  solve_mono BinRel_solve_mono.
Qed.

Fixpoint ceval (c: com): state -> state -> Prop :=
  match c with
  | CSkip => Rel.id
  | CAss X E =>
      fun st1 st2 =>
        st2 X = aeval E st1 /\
        forall Y, X <> Y -> st1 Y = st2 Y
  | CSeq c1 c2 => Rel.concat (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1) (ceval c2)
  | CWhile b c => loop_sem (beval b) (ceval c)
  end.


Require Import Coq.Arith.EqNat.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.

Require Import Hapsl.Bool.Bool.
Require Import Hapsl.Ascii.Equality.

Import AsciiEqualityNotations.

(* Calculates the Hamming distance between two strings. *)
Fixpoint hamming_distance (a b : string) : option nat :=
  match a, b with
    | EmptyString, EmptyString => Some 0
    | String ca a', String cb b' =>
      match hamming_distance a' b' with
        | None => None
        | Some n => Some ((nat_of_bool (negb (ca ==_a cb))) + n)
      end
    | _, _ => None
  end.

(* TODO: Prove lemma - Hamming distance is undefined for strings with differing
   lengths. *)
Lemma hamming_distance_undefined_for_different_lengths : forall (a b : string),
  length a <> length b <-> hamming_distance a b = None.
Proof.
  Admitted.

(* TODO: Prove lemma - Hamming distance is defined for strings with the same
   length. *)
Lemma hamming_distance_defined_for_same_length : forall (a b : string),
  length a = length b -> hamming_distance a b <> None.
Proof.
  Admitted.

(* Hamming distance is 0 for identical strings. *)
Lemma hamming_distance_zero_for_identical : forall (s: string),
  hamming_distance s s = Some 0.
Proof.
  induction s.
    - auto.
    - unfold hamming_distance.
      rewrite beq_ascii_reflexive.
      simpl.
      fold hamming_distance.
      rewrite IHs.
      reflexivity.
Qed.

(* TODO: Prove lemma - Hamming distance is at most string length. *)
Lemma hamming_distance_at_most_string_length : forall (a b : string),
  True.
  (* TODO: Option nat conversion. *)
  (* length a = length b -> hamming_distance a b <= length a. *)
Proof.
  Admitted.

(* The Levenshtein indicator function that will return 0 if the character at
   each given position is each given string is equal, otherwise returns 1. *)
Definition indicator (a b : string) (i j : nat) : nat :=
  nat_of_bool (negb ((get (i - 1) a) ?==_a (get (j - 1) b))).

(* The Levenshtein distance function. Returns the number of insertions,
   deletions and substitutions required to go from one string to another. *)
Fixpoint levenshtein (a b : string) (i j n : nat) : nat :=
  match i, j, n with
    | O, _, _ | _, O, _ | _, _, O => max i j
    | S i', S j', S n' => min
      ((levenshtein a b i' j n') + 1)
      (min
        ((levenshtein a b i j' n') + 1)
        ((levenshtein a b i' j' n') + (indicator a b i j)))
  end.

(* Calculates the Levenshtein distance between two strings. *)
Definition levenshtein_distance (a b : string) : nat :=
  let i := length a in
    let j := length b in
      let n := max i j in
        levenshtein a b i j n.

(* Returns the length difference between two strings. *)
Fixpoint string_length_diff (a b : string) : nat :=
  match a, b with
    | EmptyString, EmptyString => 0
    | _, EmptyString => length a
    | EmptyString, _ => length b
    | String ca a', String cb b' => string_length_diff a' b'
  end.

(* TODO: Prove lemma - It is always at least the difference of the sizes of the
   two strings. *)
Lemma levenshtein_distance_at_least_length_diff : forall (a b : string),
  levenshtein_distance a b >= string_length_diff a b.
Proof.
  Admitted.

(* TODO: Prove lemma - It is zero if and only if the strings are equal. *)
Lemma levenshtein_distance_zero_for_equal_strings : forall (a b : string),
  a = b <-> levenshtein_distance a b = 0.
Proof.
  Admitted.

(* TODO: Prove lemma - If the strings are the same size, the Hamming distance is
   an upper bound on the Levenshtein distance. *)
Lemma levenshtein_distance_same_length_leq_hamming : forall (a b : string),
  True.
  (* TODO: Option nat conversion. *)
  (* length a = length b -> levenshtein_distance a b <= hamming_distance a b. *)
Proof.
  Admitted.

(* TODO: Prove lemma - It is at most the length of the longer string. *)
Lemma levenshtein_distance_leq_longer_string_length : forall (a b : string),
  levenshtein_distance a b <= max (length a) (length b).
Proof.
  Admitted.

(* TODO: Prove lemma - The Levenshtein distance between two strings is no
   greater than the sum of their Levenshtein distances from a third string
   (triangle inequality). *)
Lemma levenshtein_distance_triangle_inequality : forall (a b c : string),
  levenshtein_distance a b <= (levenshtein_distance a c)
    + (levenshtein_distance b c).
Proof.
  Admitted.


Module Note.

  (* Syntax: *)

  Inductive Exp : Type :=
  | T
  | F
  | And (b1 : Exp) (b2 : Exp)
  | If  (b : Exp)  (b1 : Exp) (b2 : Exp).

  Notation "b1 /*\ b2" := (And b1 b2) (at level 50, left associativity).

  Definition exp1 : Exp := T.
  Definition exp2 : Exp := T /*\ F.
  Definition exp3 : Exp := If exp2 (T /*\ T) F.

  (* An indexed data type (b is the index):
      isVal T
      isVal F
  *)
  Inductive isVal : Exp -> Prop :=
  | valT : isVal T
  | valF : isVal F.

  (* Parameterized Data Type (b is the parameter): *)
  Inductive isVal' (b : Exp) : Prop :=
  | valT' : b = T -> isVal' b
  | valF' : b = F -> isVal' b.

  (* Evaluation: Single and Multi *)

  Fixpoint eval (b : Exp) : Exp :=
    match b with
    | T => T
    | F => F
    | T /*\ T => T (* AndT  *)
    | F /*\ T => F (* AndF1 *)
    | T /*\ F => F (* AndF2 *)
    | F /*\ F => F (* AndF  *)
    | b1 /*\ b2 =>
      match (eval b1) with
      | T => eval b2
      | F => F
      | _ => b1 /*\ b2
      end
    | If b b1 b2 =>
      match eval b with
      | T => eval b1
      | F => eval b2
      | _ => If b b1 b2
      end
    end.

  Lemma isval_to_val : forall (b : Exp),
      isVal b -> b = T \/ b = F.
  Proof.
    intros.
    destruct H.
    left.
    trivial.
    right.
    trivial.
  Qed.

  Lemma eval_T : forall (b : Exp),
   eval b = T ->
     (b = T)
  \/ (exists (b1 b2 : Exp), b = b1 /*\ b2)
  \/ (exists (b1 b2 b3 : Exp), b = If b1 b2 b3).
  Proof.
    intros.
    destruct b.
    - left. trivial.
    - left. trivial.
    - right. left. exists b1. exists b2. trivial.
    - right. right. exists b1. exists b2. exists b3. trivial.
  Qed.

  Lemma eval_and : forall (b1 b2 : Exp),
        (eval b1 = T \/ eval b1 = F) ->
        (eval b2 = T \/ eval b1 = F) ->
        (eval (b1 /*\ b2) = T \/ eval (b1 /*\ b2) = F).
  Proof.
    intros.
    destruct H.
    - destruct H0.
      left.
      simpl.
      rewrite H.
      rewrite H0.
      destruct (eval_T b1).
      * apply H.
      * rewrite H1. destruct (eval_T b2).
      + apply H0.
      + rewrite H2. trivial.
      +  destruct H2.
         { destruct H2. destruct H2. rewrite H2. trivial. }
         { destruct H2. destruct H2. destruct H2. rewrite H2. trivial. }
      *

  Lemma eval_to_val : forall (b : Exp), isVal (eval b).
  Proof.
    intro b.
    induction b.
    apply valT.
    apply valF.

    (* isVal (eval b1) -> eval b1 = T \/ eval b1 = F
    * isVal (eval b2) -> eval b2 = T \/ eval b1 = F
    * ---------------------------------------------
    * eval (b1 /*\ b2) = T \/ eval (b1 /*\ b2) = F  *)

  Compute (eval (If (T /*\ T) (F /*\ T) T)).

End Note.


Require Import Relation.
Require Import Ordering.

(* operations *)

Theorem n_plus_identity : forall (n : nat),
  n + 0 = n.
Proof.
induction n.
- reflexivity.
- simpl. rewrite IHn. reflexivity.
Qed.

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

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

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

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

Theorem n_plus_cancel : forall (n m k: nat),
  n + k = m + k <-> n = m.
Proof.
intros. unfold iff. apply conj.
- induction k.
  + rewrite n_plus_identity. rewrite n_plus_identity. intros. apply H.
  + intros. rewrite n_plus_n_Sm in H. rewrite n_plus_n_Sm in H.
    inversion H. apply IHk. apply H1.
- intros. rewrite H. reflexivity.
Qed.

Theorem n_mul_identity : forall n : nat,
  n * 1 = n.
Proof.
induction n.
  - reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

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

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

Theorem n_mul_comm : forall (n m : nat),
  n * m = m * n.
Proof.
intros.
induction n.
  - rewrite n_mul_zero. reflexivity.
  - simpl. rewrite IHn. rewrite n_mul_right. rewrite n_plus_comm. reflexivity.
Qed.

Theorem n_distributive : forall (n m k : nat),
  n * (m + k) = n * m + n * k.
Proof.
intros.
induction n.
  - reflexivity.
  - simpl.
assert (H : (k + n * (m + k)) = n * m + (k + n * k)).
rewrite IHn. rewrite n_plus_assoc. rewrite n_plus_comm with (n:=k). rewrite n_plus_assoc. reflexivity.
rewrite <- n_plus_assoc. rewrite H. rewrite n_plus_assoc. reflexivity.
Qed.

Theorem n_right_distributive : forall (n m k : nat),
  (n + m) * k = n * k + m * k.
Proof.
intros. rewrite n_mul_comm. rewrite n_mul_comm with (n:=n). rewrite n_mul_comm with (n:=m).
apply n_distributive.
Qed.

Theorem n_mul_assoc : forall (n m k : nat),
  n * (m * k) = (n * m) * k.
Proof.
intros.
induction n.
  - reflexivity.
  - simpl. rewrite IHn. rewrite n_mul_comm with (n:=m+n*m). rewrite n_distributive. rewrite n_mul_comm.
assert (H : (n*m*k = k*(n*m))).
rewrite n_mul_comm with (m:=n*m). reflexivity.
rewrite H. reflexivity.
Qed.

(* inequalities *)

Definition n_le : Relation nat nat :=
fun p => match p with
  | (n, m) => n <= m
end.

Definition n_lt : Relation nat nat :=
fun p => match p with
  | (n, m) => n < m
end.

Definition n_ge : Relation nat nat :=
fun p => match p with
  | (n, m) => m <= n
end.

Definition n_gt : Relation nat nat :=
fun p => match p with
  | (n, m) => m < n
end.

Theorem n_le_0_n : forall (n : nat),
  0 <= n.
Proof.
induction n.
- apply le_n.
- apply le_S. apply IHn.
Qed.

Theorem n_le_reflexive : forall (n : nat),
  n <= n.
Proof.
intros. apply le_n.
Qed.

Theorem n_le_n_S_m : forall (n m : nat),
  n <= S m <-> n <= m \/ n = S m.
Proof.
unfold iff. intros. apply conj.
- intros. inversion H.
  + apply or_intror. reflexivity.
  + apply or_introl. apply H1.
- intros. inversion H.
  + apply le_S. apply H0.
  + rewrite H0. apply le_n.
Qed.

Theorem n_le_transitive : forall (n m k : nat),
  n <= m -> m <= k -> n <= k.
Proof.
induction k.
- intros nm m0. inversion m0 as [meq0|]. rewrite meq0 in nm. apply nm.
- intros nm mSk. inversion mSk as [meqSk | m0  mk].
  + rewrite meqSk in nm. apply nm.
  + apply le_S. apply IHk. apply nm. apply mk.
Qed.

Theorem n_le_Sn_n_false : forall (n : nat),
  not (S n <= n).
Proof.
induction n.
- intros H. inversion H.
- intros H. inversion H.
  + apply IHn. rewrite H1. apply le_n.
  + apply IHn. apply n_le_transitive with (m:= S (S n)).
    apply le_S. apply le_n. apply H1.
Qed.

Theorem n_le_Sn_Sm : forall (n m : nat),
  S n <= S m <-> n <= m.
Proof.
unfold iff. intros. apply conj.
- intros. inversion H.
  + apply le_n.
  + apply n_le_transitive with (m:=S n)(k := m).
    apply le_S. apply le_n. apply H1.
- intros. induction m.
  + inversion H. apply le_n.
  + inversion H.
    * apply le_n.
    * apply IHm in H1. apply n_le_transitive with (m:=S m).
      apply H1. apply le_S. apply le_n.
Qed.

Theorem n_le_antisymmetric : forall (n m : nat),
  n <= m -> m <= n -> n = m.
Proof.
intros n m nm mn. inversion nm.
+ reflexivity.
+ assert (contra : S m0 <= m0).
  { rewrite <- H0 in mn. apply n_le_transitive with (m:=n). apply mn. apply H. }
  apply n_le_Sn_n_false in contra. contradiction.
Qed.

Theorem n_le_total_ordering : forall (n m : nat),
  n <= m \/ m <= n.
Proof.
intros. induction m.
- right. apply n_le_0_n.
- destruct IHm.
  + left. apply le_S. apply H.
  + inversion H.
    * left. apply le_S. apply le_n.
    * right. apply n_le_Sn_Sm. apply H0.
Qed.

Theorem n_le_total_partial_ordering : total_partial_ordering n_le.
Proof.
unfold total_partial_ordering. apply conj.
- unfold partial_ordering. apply conj.
  + unfold reflexive. apply n_le_reflexive.
  + apply conj.
    * unfold antisymmetric. apply n_le_antisymmetric.
    * unfold transitive. apply n_le_transitive.
- apply n_le_total_ordering.
Qed.

Theorem n_lt_is_strict_n_le : n_lt = partial_to_strict n_le.
Proof.
apply Relation_eq. intros. unfold iff. apply conj.
- intros. apply conj.
  + apply n_le_Sn_Sm. apply n_le_transitive with (m:=b).
    apply H. apply le_S. apply le_n.
  + intros eq. rewrite eq in H. apply n_le_Sn_n_false in H. contradiction.
- intros. destruct H as [leab neq].
  inversion leab.
  + contradiction.
  + apply n_le_Sn_Sm. apply H.
Qed.

Theorem n_le_is_partial_n_lt : n_le = strict_to_partial n_lt.
Proof.
rewrite n_lt_is_strict_n_le. apply eq_sym.
apply partial_to_strict_to_partial_identity.
apply n_le_total_partial_ordering.
Qed.

Theorem n_lt_total_strict_ordering : total_strict_ordering n_lt.
Proof.
rewrite n_lt_is_strict_n_le.
apply partial_to_strict_preserves_totality.
apply n_le_total_partial_ordering.
Qed.

Theorem n_le_plus : forall (n m k : nat),
  n <= m <-> n + k <= m + k.
Proof.
unfold iff. intros. apply conj.
- intros. induction k.
  + rewrite n_plus_identity. rewrite n_plus_identity. apply H.
  + rewrite n_plus_n_Sm. rewrite n_plus_n_Sm.
    apply n_le_Sn_Sm. apply IHk.
- intros. induction k.
  + rewrite n_plus_identity in H. rewrite n_plus_identity in H. apply H.
  + rewrite n_plus_n_Sm in H. rewrite n_plus_n_Sm in H.
    apply -> n_le_Sn_Sm in H. apply IHk. apply H.
Qed.

Theorem n_le_mul : forall (n m k : nat),
  n <= m -> n * k <= m * k.
Proof.
intros. induction k.
- rewrite n_mul_zero. rewrite n_mul_zero. apply le_n.
- rewrite n_mul_comm. rewrite n_mul_comm with (n:=m).
  simpl. rewrite n_mul_comm. rewrite n_mul_comm with (m:=m).
  apply n_le_transitive with (m:=n+m*k).
  + rewrite n_plus_comm. rewrite n_plus_comm with (n:=n).
    apply n_le_plus. apply IHk.
  + apply n_le_plus. apply H.
Qed.

Theorem n_le_sum : forall (n m k l : nat),
  n <= m -> k <= l -> n + k <= m + l.
Proof.
intros n m k l nm kl. apply n_le_transitive with (m:=m+k).
- apply n_le_plus. apply nm.
- rewrite n_plus_comm. rewrite n_plus_comm with (n:=m).
  apply n_le_plus. apply kl.
Qed.

Theorem n_lt_plus : forall (n m k : nat),
  n < m <-> n + k < m + k.
Proof.
intros. unfold lt.
rewrite n_plus_comm. rewrite <- n_plus_n_Sm. rewrite n_plus_comm.
apply n_le_plus.
Qed.

Theorem n_lt_mul : forall (n m k : nat),
  n < m -> 0 < k -> n * k < m * k.
Proof.
intros n m k nm kpos. apply n_le_mul with (k:=k) in nm.
simpl in nm. rewrite n_plus_comm in nm. apply n_le_transitive with (m:=n*k+k).
- rewrite <- n_plus_one. rewrite n_plus_comm. rewrite n_plus_comm with (m:=k).
  apply n_le_plus. apply kpos.
- apply nm.
Qed.

Theorem n_le_lt_sum : forall (n m k l : nat),
  n < m -> k <= l -> n + k < m + l.
Proof.
intros n m k l nm kl.
rewrite n_plus_comm. unfold lt. rewrite <- n_plus_n_Sm. rewrite n_plus_comm.
apply n_le_sum. apply nm. apply kl.
Qed.

Theorem n_lt_sum : forall (n m k l : nat),
  n < m -> k < l -> n + k < m + l.
Proof.
intros n m k l nm kl. apply n_le_lt_sum. apply nm. apply le_S in kl. apply n_le_Sn_Sm. apply kl.
Qed.

Theorem n_lt_lemma1 : forall (n m k l : nat),
  n < m -> k < l -> n * l + m * k < n * k + m * l.
Proof.
intros n m k l nm kl. induction l.
- inversion kl.
- rewrite <- n_plus_one. rewrite n_distributive. rewrite n_distributive.
  rewrite n_mul_identity. rewrite n_mul_identity.
  inversion kl.
  + rewrite n_plus_comm with (m:=m). rewrite n_plus_assoc. apply n_lt_plus.
    rewrite n_plus_comm. rewrite n_plus_comm with (m:=m). apply n_lt_plus.
    apply nm.
  + rewrite <- n_plus_assoc. rewrite n_plus_comm with (n:=n).
    rewrite n_plus_assoc. rewrite n_plus_assoc.
    apply n_lt_sum. apply IHl. apply H0. apply nm.
Qed.


Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

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

Fixpoint append(m n :natlist) : natlist :=
match m with
|[] => n
|a :: b => a::(append b n)
end.

Fixpoint snoc(m:natlist)(n:nat) :natlist:=
match m with
|[] => [n]
|a::b => a:: (snoc b n)
end.

Notation "x ++ y" := (append x y)(at level 60, right associativity).

Theorem appendList : forall (list : natlist) (n : nat), snoc list n = list ++ [n].
Proof.
  intros.
    induction list as [| x xs].
    simpl.
    reflexivity.
    simpl.
    rewrite -> IHxs.
    reflexivity.
Qed.


Require Import Coq.omega.Omega.
Inductive seq : Type :=
| empty : seq
| pair  : nat -> seq -> seq.
(* lexicographical ordering less than or equal <= *)
Fixpoint lessOrEq (s t: seq) : Prop :=
match s with
| empty     => True
| pair a s1 => match t  with
| empty     => False
| pair b t1 =>  (a < b) \/
((a = b) /\ (lessOrEq s1 t1))
end
end.
Lemma test1 : not (lessOrEq (pair 4 (pair 3 empty))
(pair 3 empty)).
Proof.

intro.
destruct H.
omega.
destruct H.
contradiction.

Qed.
Lemma test2 : lessOrEq (pair 4 (pair 3 empty))
(pair 4 (pair 3 (pair 2 empty))).
Proof.

simpl.
intuition.

Qed.


Require Import ch1.Simplification.

Theorem plus_id_example : forall n m : nat,
    n = m -> n + n = m + m.

Proof.
    intros n m.     (* "for some n <- Nat, m <- Nat" *)
    intros H.       (* "such that n = m " *)
    rewrite -> H.   (* Rewrite the goal using the hypothesis *)
    reflexivity. Qed.

(* Exercise *)

Theorem plus_id_exercise : forall n m o : nat,
    n = m -> m = o -> n + m = m + o.

Proof.
    intros n m o.
    intros H1 H2.
    rewrite -> H1.
    rewrite -> H2.
    reflexivity. Qed.

Theorem mult_0_plus : forall n m : nat,
    (0 + n) * m = n * m.

Proof.
    intros n m.
    rewrite -> plus_O_n.
    reflexivity. Qed.

(* Exercise *)

Theorem mult_S_1 : forall n m : nat,
    m = S n -> m * (1 + n) = m * m.
Proof.
    intros n m.
    intros H.
    rewrite -> H.
    reflexivity. Qed.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Fixpoint qreva (qreva_arg0 : Lst) (qreva_arg1 : Lst) : Lst
           := match qreva_arg0, qreva_arg1 with
              | nil, x => x
              | cons z x, y => qreva x (cons z y)
              end.

Lemma append_nil : forall (x : Lst), append x nil = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : Lst), append (append x y) z = append x (append y z).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : Lst), rev (append x y) = append (rev y) (rev x).
Proof.
  intros.
  induction x.
  - simpl. rewrite append_nil. reflexivity.
  - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : Lst), rev (rev x) = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Lemma qreva_rev : forall (x y : Lst), qreva x y = append (rev x) y.
Proof.
  induction x.
  - reflexivity.
  - intros. simpl. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (qreva (qreva x (rev y)) nil) (append y x).
Proof.
  induction x.
  - intros. simpl. rewrite qreva_rev. rewrite rev_rev. reflexivity.
  - intros. simpl. rewrite (eq_refl : cons n (rev y) = append (rev (cons n nil)) (rev y)). rewrite <- rev_append. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Tactics.DivideExistsMul.
Local Open Scope Z_scope.

Module Z.
  Lemma divide_mul_div: forall a b c (a_nonzero : a <> 0) (c_nonzero : c <> 0),
    (a | b * (a / c)) -> (c | a) -> (c | b).
  Proof.
    intros ? ? ? ? ? divide_a divide_c_a; do 2 Z.divide_exists_mul.
    rewrite divide_c_a in divide_a.
    rewrite Z.div_mul' in divide_a by auto.
    replace (b * k) with (k * b) in divide_a by ring.
    replace (c * k * k0) with (k * (k0 * c)) in divide_a by ring.
    rewrite Z.mul_cancel_l in divide_a by (intuition auto with nia; rewrite H in divide_c_a; ring_simplify in divide_a; intuition).
    eapply Zdivide_intro; eauto.
  Qed.

  Lemma divide2_even_iff : forall n, (2 | n) <-> Z.even n = true.
  Proof.
    intros n; split. {
      intro divide2_n.
      Z.divide_exists_mul; [ | pose proof (Z.mod_pos_bound n 2); lia].
      rewrite divide2_n.
      apply Z.even_mul.
    } {
      intro n_even.
      pose proof (Zmod_even n) as H.
      rewrite n_even in H.
      apply Zmod_divide; lia || auto.
    }
  Qed.

  Lemma divide_pow_le b n m : 0 <= n <= m -> (b ^ n | b ^ m).
  Proof.
    intros. replace m with (n + (m - n)) by ring.
    rewrite Z.pow_add_r by lia.
    apply Z.divide_factor_l.
  Qed.
End Z.


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

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

Inductive bool : Type :=
  | true
  | false.

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

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

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

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

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

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

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

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

Module NatPlayground.

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

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

End NatPlayground.

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

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

Compute (minustwo 4).

Check S.
Check pred.
Check minustwo.

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

Definition oddb (n:nat) : bool   :=   negb (evenb n).

Example test_oddb1:    oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2:    oddb 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

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

Compute (plus 3 2).

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

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

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

End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

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

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

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

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

Check ((0 + 1) + 1).

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

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => 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 := leb (S n) m.

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

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

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

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

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

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

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H.
  intros K.
  rewrite -> H.
  rewrite -> K.
  reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> plus_1_l.
  rewrite -> H.
  reflexivity.
Qed.

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

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

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

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

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  destruct b as [t0|f0] eqn:Eb.
  - destruct c as [t|f] eqn:Ec.
    + simpl.
      reflexivity.
    + simpl.
      intros H.
      rewrite -> H.
      reflexivity.
  - destruct c as [t|f] eqn:Ec.
    + simpl.
      reflexivity.
    + simpl.
      intros H.
      rewrite -> H.
      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 .
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

From Coq Require Export String.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros [] [].
  intros H.
  + reflexivity.
  + simpl. intros. rewrite -> H. reflexivity.
  + simpl. intros. rewrite -> H. reflexivity.
  + simpl. intros. reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
  match m with
  | Z => B Z
  | A n' => B n'
  | B n' => A (incr n')
  end.

Example incr1: (incr Z) = B Z.
Proof. simpl. reflexivity. Qed.

Example incr2: (incr (incr Z)) = A (B Z).
Proof. simpl. reflexivity. Qed.

Example incr3: (incr (incr (incr Z))) = B (B Z).
Proof. simpl. reflexivity. Qed.

Example incr4: (incr (incr (incr (incr Z)))) = A (A (B Z)).
Proof. simpl. reflexivity. Qed.

Example incr5: (incr (incr (incr (incr (incr Z))))) = B (A (B Z)).
Proof. simpl. reflexivity. Qed.

Example incr6: (incr (incr (incr (incr (incr (incr Z)))))) = A (B (B Z)).
Proof. simpl. reflexivity. Qed.

Example incr9: (incr (incr (incr (incr (incr (incr (incr (incr (incr (incr (incr Z))))))))))) = A (B (B (B Z))).
Proof. simpl.  Abort.

Fixpoint bin_to_nat (m:bin) :=
  match m with
  | Z => 0
  | A n => 2 * bin_to_nat n
  | B n => S (2 * bin_to_nat n)
  end.


Require Import List.
Import ListNotations.

(* Check the type of list *)
Check list.
(* It is a constructor:
   list : Type -> Type
   that maps the type of elements in the list to the list type. *)

Definition is_empty (A : Type) (lst : list A) :=
  match lst with
  | nil => true
  | cons _ _ => false
  end.

(* or *)

Definition is_empty2 (A : Type) (lst : list A) :=
  match lst with
  | [] => true
  | _::_ => false
  end.

Compute is_empty nat [1].
Compute is_empty nat [].

Theorem empty_is_empty : forall A : Type, forall lst : list A,
      length lst = 0 -> is_empty A lst = true.
Proof.
  intros A lst H.
  (* lst has two possible values: nil and cons.
     Both subgoals assume H, that is, length lst = 0.
     The first subgoal has H true, because length nil = 0.
          is_empty A [] = true, so this subgoal is proved
          with trivial.
     The second subgoal has H false. Because H is false, we
         use discriminate. Again, discriminate lets us prove
         anything when one of our assumptions is false. *)
  destruct lst.
    trivial.
    discriminate.
Qed.


From Coq Require Import List Arith.

Local Open Scope list_scope.

Lemma skipn_skipn {A} (l: list A) (n m: nat):
  skipn n (skipn m l) = skipn (n + m) l.
Proof.
revert n l.
induction m, l; intros; try repeat rewrite skipn_nil; try easy.
{ cbn. now rewrite Nat.add_0_r. }
replace (n + S m) with (S (n + m)) by auto with arith.
repeat rewrite skipn_cons.
apply IHm.
Qed.

Lemma nth_hd_skipn {A} (l: list A) (n: nat):
  nth_error l n = hd_error (skipn n l).
Proof.
revert l. induction n, l; try easy.
cbn. apply IHn.
Qed.

Fixpoint list_eqb {A} (eqb: A -> A -> bool) (l l': list A)
: bool
:= match l with
   | nil => match l' with
            | nil => true
            | _ => false
            end
   | h :: t => match l' with
               | nil => false
               | h' :: t' => if eqb h h'
                               then list_eqb eqb t t'
                               else false
               end
   end.


Require Export Basics.

Theorem plus_n_0 : forall n : nat, n = n+0.
Proof.
  intro n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n,
minus n n = 0.
  Proof.
    intro. induction n.
    - simpl. reflexivity.
    - simpl. rewrite -> IHn. reflexivity.
  Qed.

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

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

Theorem plus_comm : forall n m : nat,
 n + m = m + n.
Proof.
  intros. induction n; simpl.
  - rewrite <- plus_n_0. reflexivity.
  - rewrite -> IHn. apply plus_n_Sm.
Qed.

Theorem plus_assoc : forall n m o : nat,
 (n + m) + o = n + (m + o).
Proof.
  intros. induction n; simpl.
  - reflexivity.
  - rewrite -> IHn. reflexivity.
Qed.

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

Compute (double 6).

Lemma double_plus : forall n, double n = n+n.
Proof.
  intro. induction n; simpl.
  - reflexivity.
  - rewrite -> IHn. rewrite <- plus_n_Sm. reflexivity.
Qed.

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  intro. induction n.
  - reflexivity.
  - rewrite -> IHn. simpl. rewrite -> negb_involutive. reflexivity.
Qed.

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

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


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Nat Lia.

Set Implicit Arguments.

Section interval.

  (* A small interval & valuation library *)

  Definition interval := (nat * nat)%type. (* (a,b) <~~~> [a,b[ *)

  Implicit Types (i j : interval).

  Definition in_interval i x := let (a,b) := i in a <= x < b.
  Definition out_interval i x := let (a,b) := i in x < a \/ b <= x.
  Definition interval_disjoint i j := forall x, in_interval i x -> in_interval j x -> False.

  Definition interval_union (i j : interval) :=
    match i, j with (a1,b1),(a2,b2) => (min a1 a2, max b1 b2) end.

  Fact in_out_interval i x : in_interval i x -> out_interval i x -> False.
  Proof. destruct i; simpl; lia. Qed.

  Fact in_out_interval_dec i x : { in_interval i x } + { out_interval i x }.
  Proof.
    destruct i as (a,b); simpl.
    destruct (le_lt_dec a x); destruct (le_lt_dec b x); try (left; lia);right; lia.
  Qed.

  Fact interval_union_left i j x : in_interval i x -> in_interval (interval_union i j) x.
  Proof.
    revert i j; intros (a,b) (u,v); simpl.
    generalize (Nat.le_min_l a u) (Nat.le_max_l b v); lia.
  Qed.

  Fact interval_union_right i j x : in_interval j x -> in_interval (interval_union i j) x.
  Proof.
    revert i j; intros (a,b) (u,v); simpl.
    generalize (Nat.le_min_r a u) (Nat.le_max_r b v); lia.
  Qed.

  Definition valuation_union i1 (g1 : nat -> nat) i2 g2 :
               interval_disjoint i1 i2
            -> { g | (forall x, in_interval i1 x -> g x = g1 x)
                  /\ (forall x, in_interval i2 x -> g x = g2 x) }.
  Proof.
    intros H2.
    exists (fun x => if in_out_interval_dec i1 x then g1 x else g2 x).
    split; intros x Hx.
    + destruct (in_out_interval_dec i1 x) as [ | H3 ]; auto.
      exfalso; revert Hx H3; apply in_out_interval.
    + destruct (in_out_interval_dec i1 x) as [ H3 | ]; auto.
      exfalso; revert H3 Hx; apply H2.
  Qed.

  Definition valuation_one_union k v i1 (g1 : nat -> nat) i2 g2 :
               ~ in_interval (interval_union i1 i2) k
            -> interval_disjoint i1 i2
            -> { g | g k = v /\ (forall x, in_interval i1 x -> g x = g1 x)
                             /\ (forall x, in_interval i2 x -> g x = g2 x) }.
  Proof.
    intros H1 H2.
    exists (fun x => if eq_nat_dec x k then v
                     else if in_out_interval_dec i1 x then g1 x
                     else g2 x).
    split; [ | split ].
    + destruct (eq_nat_dec k k) as [ | [] ]; auto.
    + intros x Hx.
      destruct (eq_nat_dec x k) as [ | ].
      * subst; destruct H1; apply interval_union_left; auto.
      * destruct (in_out_interval_dec i1 x) as [ | H3 ]; auto.
        exfalso; revert Hx H3; apply in_out_interval.
    + intros x Hx.
      destruct (eq_nat_dec x k) as [ | ].
      * subst; destruct H1; apply interval_union_right; auto.
      * destruct (in_out_interval_dec i1 x) as [ H3 | ]; auto.
        exfalso; revert H3 Hx; apply H2.
  Qed.

End interval.


(* Solution for exercieses in Tsinghua Coq Summber School.
  Exercise for leture 3: Proofs in Proposition Logic and Predicate Logic by Pierre Castéran. *)

(** This file contains some lemmas you will have to prove, i.e. replacing
   the "Admitted" joker with a sequence of tactic calls, terminated with a
   "Qed" command.

   Each lemma should be proved several times :
   first using only elementary tactics :
   intro[s], apply, assumption
   split, left, right, destruct.
   exists, rewrite
   assert (only if you don't find another solution)

   Then, use tactic composition, auto, tauto, firstorder.

Notice that, if you want to keep all solutions, you may use various
identifiers like in the given example : imp_dist, imp_dist' share
the same statement, with different interactive proofs.
*)

Section Minimal_propositioal_logic.

Variables P Q R S : Prop.

Lemma imp_dist : (P -> Q -> R) -> (P -> Q) -> P -> R.
Proof.
  intros H H0 p.
  apply H.
  assumption.
  apply H0.
  assumption.
Qed.

Lemma imp_dist' : (P -> Q -> R) -> (P -> Q) -> P -> R.
Proof.
  intros H H0 p;apply H.
  assumption.
  apply H0;assumption.
Qed.

Lemma id_P : P -> P.
Proof.
  intro H.
  assumption.
Qed.

Lemma id_P' : P -> P.
Proof.
  intros h1.
  apply h1.
Qed.

Lemma id_PP : (P -> P) -> P -> P.
Proof.
  intros h1 h2.
  apply h2.
Qed.

Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros h1 h2 h3.
  apply h2; apply h1; apply h3.
Qed.

Lemma imp_perm : (P -> Q -> R) -> Q -> P -> R.
Proof.
  intros h1 h2 h3.
  apply h1; [apply h3 | apply h2].
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  intros h1 h2 h3.
  apply h1; apply h2.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  intros h1 h2.
  apply h1; [apply h2 | apply h2].
Qed.

Lemma delta_impR : (P -> Q) -> P -> P -> Q.
Proof.
  intros h1 h2 h3.
  apply h1; apply h2.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
Proof.
  intros h1 h2 h3 h4.
  apply h3.
  apply h1; apply h4.
  apply h2; apply h4.
Qed.

Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros h1.
  apply h1.
  intros h2.
  apply h2.
  intros h3.
  apply h1.
  intros h4.
  apply h3.
Qed.

End Minimal_propositioal_logic.

(** Same exercise as the previous one, with full intuitionistic propositional
   logic

   You may use the tactics intro[s], apply, assumption, destruct,
                           left, right, split and try to use tactic composition *)

Section propositional_logic.

Variables P Q R S T : Prop.

Lemma and_assoc : P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intro h1.
  split; [split | idtac]; apply h1.
Qed.

Lemma and_imp_dist : (P -> Q) /\ (R -> S) -> P /\ R -> Q /\ S.
Proof.
  intros h1 h2.
  elim h1.
  intros h3 h4.
  split; [apply h3 | apply h4]; apply h2.
Qed.

Lemma not_contrad :  ~(P /\ ~P).
Proof.
  intros h1.
  elim h1.
  intros h2 h3.
  apply h3; apply h2.
Qed.

Lemma or_and_not : (P \/ Q) /\ ~P -> Q.
Proof.
  intros h1.
  elim h1.
  intros h2 h3.
  elim h2;
    [ intros h4; elim h3; apply h4
    | trivial
    ].
Qed.

Lemma not_not_exm : ~ ~ (P \/ ~ P).
Proof.
  intros h1.
  elim h1; right; intro h2.
  elim h1; left; apply h2.
Qed.

Lemma de_morgan_1 : ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  intros h1.
  split; intros h2; elim h1; [left | right]; assumption.
Qed.

Lemma de_morgan_2 : ~P /\ ~Q -> ~(P \/ Q).
Proof.
  intros h1 h2.
  elim h2; (* "unfold not in h1;" *) apply h1.
Qed.

Lemma de_morgan_3 : ~P \/ ~Q -> ~(P /\ Q).
Proof.
  intros h1 h2.
  elim h2.
  intros h3 h4.
  elim h1;
    [ intros h5; apply h5
    | intros h6; apply h6
    ];
    assumption.
Qed.

End propositional_logic.

Section First_Order_Logic.

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

Lemma forall_imp_dist : (
  forall x : A, P x -> Q x) -> (
    forall x : A, P x) ->
      forall x : A, Q x.
Proof.
  intros h1 h2 x.
  apply h1; apply h2.
Qed.

Lemma forall_perm : (
  forall x y : A, R x y) ->
    forall y x, R x y.
Proof.
  intros h1 y x.
  apply h1.
Qed.

Lemma forall_delta : (
  forall x y : A, R x y) ->
    forall x, R x x.
Proof.
  intros h1 x.
  apply h1.
Qed.

Lemma exists_or_dist : (
  exists x : A, P x \/ Q x) <-> (
    exists x, P x) \/ (
      exists x, Q x).
Proof.
  split.

  intros h1; elim h1.
  intros x h2; elim h2;
    intros;
      [ left
      | right
      ];
    exists x; assumption.

  intros h1; elim h1;
    intros h2; elim h2;
    intros x h3;
    exists x;
      [ left
      | right
      ];
    assumption.
Qed.

Lemma exists_imp_dist : (
  exists x : A, P x -> Q x) -> (
    forall x : A, P x) ->
      exists x:A, Q x.
Proof.
  intros h1 h2.
  elim h1.
  intros x h3.
  exists x.
  apply h3; apply h2.
Qed.

Lemma not_empty_forall_exists :
  forall a : A, (
    forall x : A, P x) ->
      exists x : A, P x.
Proof.
  intros a h1.
  exists a.
  apply h1.
Qed.

Lemma not_ex_forall_not : ~ (
  exists x : A, P x) <->
    forall x : A, ~ P x.
Proof.
  split.

  intros h1 x h2.
  elim h1.
  exists x.
  apply h2.

  intros h1 h2.
  elim h2.
  intros x.
  apply h1.
Qed.

Lemma singleton_forall_eq : (
  exists x : A,
    forall y : A, x = y) ->
      forall z t : A, z = t.
Proof.
  intros h1 z t.
  elim h1.
  intros x h2.
  rewrite <- (h2 t).
  apply eq_sym. (* rewrite goal using the symmetry of equal relation. *)
  rewrite <- (h2 z).
  reflexivity.
Qed.

Print singleton_forall_eq.

Section S1.

Variables  (f g : A -> A).

Hypothesis f_g_perm :
  forall x : A, f (g x) = g (f x).
Hypothesis g_idempotent :
  forall x : A, g (g x) = g x.
Hypothesis f_idempotent :
  forall x : A, f (f x) = f x.

Lemma L :
  forall z, g (f (g (f (g (f z))))) = f (g z).
Proof.
  intros z.
  rewrite f_g_perm.
  rewrite g_idempotent.
  rewrite f_idempotent.
  rewrite f_g_perm.
  rewrite g_idempotent.
  rewrite f_idempotent.
  rewrite f_g_perm.
  trivial.
Qed.

Lemma L':  (
  forall x : A, ~ x = f x) -> ~ (
    exists y : A, True).
Proof.
  intros h1 h2.
  (* introduce a variable "x" into hypotheses. *)
  elim h2.
  intros x h3.
  apply (h1 (f x)).
  rewrite f_idempotent.
  trivial.
Qed.

End S1.


Require Import QArith.
Require Import Reals.
Require Import Psatz.
Require Import QArith.Qminmax.
Require Lra.

Structure Open_Interval := {
lower_bound:Q;
upper_bound:Q;
opennes : lower_bound < upper_bound}.

Definition open_membership ( x :Q )( I : Open_Interval) :=
x < upper_bound I /\ x > lower_bound I.

Definition open_waybelow ( I J :Open_Interval) :=
lower_bound J < lower_bound I /\ upper_bound I < upper_bound J.

Lemma member_transivity : forall x :Q , forall I J : Open_Interval,
open_waybelow I J -> open_membership x I -> open_membership x J.
Proof.
intros.
destruct I as [lower upper prop].
destruct J as [lower' upper' prop'].
unfold open_waybelow, open_membership.
simpl in *.
destruct H as [A1 A2].
split.
apply (Qlt_trans x upper upper').
apply H0.
apply A2.
apply (Qlt_trans lower' lower x).
apply A1.
apply H0.
Qed.

Definition open_separated (I J : Open_Interval):=
upper_bound I <= lower_bound J \/ upper_bound J <= lower_bound I.

Definition totally_open_separated (I J : Open_Interval):=
upper_bound I < lower_bound J \/ upper_bound J < lower_bound I.

Lemma separation_expansion: forall I J : Open_Interval ,
totally_open_separated I J ->
 exists I' J' , totally_open_separated I' J'
-> open_waybelow I I' -> open_waybelow J J'.
Proof.
intros.
destruct I as [lower_I upper_I prop_I].
destruct J as [lower_J upper_J prop_J].
destruct H as [A1| A2].
simpl in *.
assert (I'_prop: ((3#1)*(lower_I)-(lower_J)+(upper_I))*(1#3)<
((2#1)*(upper_I ) + (lower_J) ) * (1#3)).
lra.
exists{|lower_bound:=((3#1)*(lower_I)-(lower_J)+(upper_I))*(1#3);upper_bound :=
((2#1)*(upper_I ) + (lower_J) ) * (1#3); opennes :=I'_prop|}.
assert(J'_prop: ((2#1)*lower_J + upper_I)*(1#3) < ((3#1)*upper_J + lower_J
- upper_I)*(1#3)).
lra.
exists{|lower_bound:=((2#1)*lower_J + upper_I)*(1#3) ; upper_bound := ((3#1)*upper_J + lower_J
- upper_I)*(1#3); opennes :=J'_prop |}.
unfold totally_open_separated.
simpl in *.
unfold open_waybelow.
simpl in *.
lra.
simpl in *.
assert (J'_prop: ((3#1)*(lower_J)-(lower_I)+(upper_J))*(1#3)<
((2#1)*(upper_J ) + (lower_I) ) * (1#3)).
lra.
exists{|lower_bound:=((3#1)*(lower_J)-(lower_I)+(upper_J))*(1#3);upper_bound :=
((2#1)*(upper_J ) + (lower_I) ) * (1#3); opennes :=J'_prop|}.
assert(I'_prop: ((2#1)*lower_I + upper_J)*(1#3) < ((3#1)*upper_I + lower_I
- upper_J)*(1#3)).
lra.
exists{|lower_bound:=((2#1)*lower_I + upper_J)*(1#3) ; upper_bound := ((3#1)*upper_I + lower_I
- upper_J)*(1#3); opennes :=I'_prop |}.
unfold totally_open_separated.
simpl in *.
unfold open_waybelow.
simpl in *.
lra.
Qed.

(*Check upper_bound.*)


Add LoadPath "C:/Coq/cpdt/src".
Require Export CpdtTactics.
Require Bool Arith List.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive binop : Set := Plus | Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b:binop) : nat->nat->nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

Inductive instr : Set :=
  | iConst : nat -> instr
  | iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
  | iConst n => Some (cons n s)
  | iBinop b =>
    match s with
      | cons arg1 (cons arg2 s') => Some (cons ((binopDenote b) arg1 arg2) s')
      | _ => None
      end
  end.

Fixpoint progDenote (p:prog) (s:stack) : option stack :=
  match p with
  | nil => Some s
  | cons i p' =>
    match instrDenote i s with
      | None => None
      | Some s' => progDenote p' s'
      end
  end.

Fixpoint compile (e:exp) : prog :=
  match e with
  | Const n => cons (iConst n) nil
  | Binop b e1 e2 => app (app (compile e2)  (compile e1) ) (cons (iBinop b) nil)
  end.

Eval simpl in compile (Binop Plus (Const 2) (Const 2)).
Eval simpl in progDenote (compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))) nil.


Module Bycicles1.

(* ((Booleans)) *)

(* Exercise: 1 star (nandb) *)
Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true  => negb b2
    | false => true
  end.

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

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

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

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

(* END nandb. *)

(* Exercise: 1 star (andb3) *)

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

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

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

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

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

(* END andb3. *)

(* ((Numbers)) *)

End Bycicles1.

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

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

Definition oddb (n:nat) : bool := negb (evenb n).

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

(* Exercise: 1 star (factorial) *)

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

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

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

(* END factorial. *)

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

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

(* Exercise: 2 stars (blt_nat) *)

Definition blt_nat (n m : nat) : bool :=
  andb (ble_nat n m) (negb (beq_nat n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
  Proof. reflexivity. Qed.

Example test_blt_nat2: (blt_nat 2 4) = true.
  Proof. reflexivity. Qed.

Example test_blt_nat3: (blt_nat 4 2) = false.
  Proof. reflexivity. Qed.

(* END blt_nat. *)

(* ((Proof by Rewriting)) *)

(* Exercise: 1 star (plus_id_exercise) *)

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o NM MO.
  rewrite -> NM.
  rewrite -> MO.
  reflexivity.
Qed.

(* END plus_id_exercise. *)

(* Excercise: 2 stars (mult_S_1) *)

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m H.
  rewrite -> H.
  reflexivity.
Qed.

(* END mult_S_1. *)

(* ((Proof by Case Analysis)) *)

(* Exercise: 1 star (zero_nbeq_plus_1) *)

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

(* END zero_nbeq_plus_1. *)

(* ((More Exercises)) *)

(* Exercise: 2 stars (boolean_functions) *)

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

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

(* END boolean_functions. *)

(* Exercise: 2 stars (andb_eq_orb) *)

Lemma andb_true_b:
  forall b : bool, andb true b = b.
Proof.
  intros b.
  reflexivity.
Qed.

Lemma orb_false_b:
  forall b : bool, orb false b = b.
Proof.
  intros b.
  reflexivity.
Qed.

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

(* END andb_eq_orb. *)

(* Exercise: 3 stars (binary) *)

Inductive bin : Type :=
  | bO : bin
  | bD : bin -> bin
  | bT : bin -> bin.

Fixpoint incr (b : bin) : bin :=
  match b with
    | bO   => bT bO
    | bD p => bT p
    | bT p => bD (incr p)
  end.

Fixpoint bin_to_nat (b : bin) : nat :=
  match b with
    | bO   => O
    | bD p => bin_to_nat p + bin_to_nat p
    | bT p => S (bin_to_nat p + bin_to_nat p)
  end.

Example test_bin_incr1: bin_to_nat bO = 0.
  Proof. reflexivity. Qed.

Example test_bin_incr2: bin_to_nat (incr (incr (incr bO))) = 3.
  Proof. reflexivity. Qed.

Example test_bin_incr3: bin_to_nat (incr (incr (incr (incr (incr bO))))) = 5.
  Proof. reflexivity. Qed.

Example test_bin_incr4: bin_to_nat (incr (bT (bD (bT bO)))) = 6.
  Proof. reflexivity. Qed.

Example test_bin_incr5: bin_to_nat (incr (bD (bT (bT (bT bO))))) = 15.
  Proof. reflexivity. Qed.

(* END binary. *)

(* ((Fixpoint and Structural Recursion (Advanced))) *)

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

(*

Fixpoint fall_apart (n : nat) : nat :=
  match n with
    | O    => fall_apart (S O)
    | S O  => fall_apart (S (S O))
    | S (S O) => O
    | S p  => fall_apart p
  end.

*)

(* END decreasing. *)