(**
(Coqで)カタラン数を語らん
========================

@suharahiromichi

2020/06/28
*)

(**
# はじめに

Coq/MathComp には binomial.v というパッケージがあって、
二項係数（順列・組合せの「組合せ」）の定義と
基本的ないくつかの補題が証明されています。これを使ってなにか証明してみましょう。

このファイルは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_catalan.v

また、

https://github.com/suharahiromichi/coq/blob/master/common/ssromega.v

も必要です。

MathCompの階層としては、
有理数や環を導入する前なので、自然数の割算と剰余を使って証明を進めます。

二項係数を使って定義される、カタラン数 (Catalan Number) というものがあります
（文献[1]）。
nが自然数のとき、以下で定義されます。

```math

c_n =
\frac{1}{n + 1}\dbinom{2 n}{n}
```

これの意味については、「カタラン数を語らん」としているサイト（文献[2]）に譲ります。

ここでは、n番めのカタラン数について、

```math

c_n = \dbinom{2 n}{n} - \dbinom{2 n}{n - 1}、ただし 0 \lt n
```

が成り立つことを証明したい思います。実際には、上記ふたつの式を整理した、

```math

n \dbinom{2 n}{n} = (n + 1) \dbinom{2 n}{n - 1}、ただし 0 \lt n

```

を証明します。
*)

(**
以下では、``n``、``m`` を（0以上の）自然数とします。また、MathCompの表記にあわせて、
二項係数 $\dbinom{n}{m}$ を ``C(n, m)`` で、また、
「m は n で割り切れる」を``n | m`` で示します（除数 | 被除数）。
*)

From mathcomp Require Import all_ssreflect.
Require Import ssromega.

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

(**
# 補題
*)
Section LEMMAS.

(**
## ``n! = n (n - 1)!`` 、ただし ``0 < n``

階乗の定義から自明ですが、MathComp では ``(n + 1) = (n + 1) * n!``
でしか証明されていないので、証明しておきます。
*)
  Lemma fact_pred n : 0 < n -> n`! = n * n.-1`!.
  Proof.
    move=> Hn.
    have H := factS n.-1.
    rewrite prednK in H; last done.
    done.
  Qed.

(**
## ``(n! m!) | (n + m)!``

階乗の積と和の剰余についての補題を証明します。

「ふたつの数の和の階乗は、それぞれの数の階乗の積で割り切れる」という、
ちょっと直観に反する補題ですが、二項係数の定義から導くことができます。
*)
  Lemma divn_fact_mul_add_fact (n m p : nat) : n + m = p -> (n`! * m`!) %| p`!.
  Proof.
    move=> <-.
    have <- : 'C(n + m, m) * (n`! * m`!) = (n + m)`!.
    - rewrite -(@bin_fact (n + m) m); last by rewrite leq_addl.
      rewrite -[n + m - m]addnBA; last by rewrite leqnn.
        by rewrite subnn addn0 [m`! * n`!]mulnC.
    - rewrite -{1}[n`! * m`!]mul1n.
        by apply: dvdn_mul.
  Qed.

(**
次のふたつは、先の階乗の積と和の剰余の応用ですが、少し長くなるので、別に証明しておきます。
*)
  Lemma divn_n2_l n : 0 < n -> (n * n.-1`! * n`!) %| n.*2`!.
  Proof.
    move=> H.
    rewrite -[n * n.-1`!]fact_pred; last done.
    apply: divn_fact_mul_add_fact.
    rewrite -addnn.
    done.
  Qed.

  Lemma divn_n2_r n : 0 < n -> (n.+1 * n`! * n.-1`!) %| n.*2`!.
  Proof.
    move=> H.
    rewrite -[n.+1 * n`!]fact_pred; last done.
    apply: divn_fact_mul_add_fact.
    rewrite -addnn.
      by ssromega.
  Qed.

End LEMMAS.

Section TH.
(**
# 定理

証明の概略を示します。

(1) ``C(n, m) = n! / (m! (n - m)!)`` を使って、二項係数を階乗の式に変換する。
整理すると、

```math

\begin{eqnarray}

n \frac{(2n)!}{n! (2n-n)!} &=& (n+1) \frac{(2n)!}{(n-1)! (2n-(n-1))!}\\

n \frac{(2n)!}{n! n!} &=& (n+1) \frac{(2n)!}{(n-1)! (n+1)!}\\

n \frac{(2n)!}{n (n-1)! n!} &=& (n+1) \frac{(2n)!}{(n+1) n! (n-1)!}

\end{eqnarray}
```

が得られる。
*)

  Check muln_divA : forall d m n : nat, d %| n -> m * (n %/ d) = (m * n) %/ d.
(**
(2) 補題``muln_divA``を使い、左辺は ``(n * □) / (n * ■)`` に変換する。また、
右辺は ``((n+1) * ○) / ((n+1) * ●)`` に変換する。
このとき、先に証明した階乗の積と和の補題を使います。

```math

\frac{n (2n)!}{n (n-1)! n!} = \frac{(n+1)(2n)!}{(n+1) n! (n-1)!}
```
 *)

  Check divnMl : forall p m d : nat, 0 < p -> (p * m) %/ (p * d) = m %/ d.
(**
(3) 補題``divnMl``を使い、左辺から ``n``、右辺から ``n+1``を消す。

```math

\frac{(2n)!}{(n-1)! n!} = \frac{(2n)!}{n! (n-1)!}\\
```

``左辺 = 右辺`` で証明が終わりです。
*)
  Theorem catalan_rel n : 0 < n -> n * 'C(n.*2, n) = n.+1 * 'C(n.*2, n.+1).
  Proof.
    move=> Hn.

    (* LHS *)
    (* (1) *)
    rewrite bin_factd; last by rewrite double_gt0.
    have -> : n.*2 - n = n by rewrite -addnn; ssromega.
    rewrite {1}[in n`! * n`!]fact_pred; last done.
    (* (2) *)
    rewrite muln_divA; last by rewrite divn_n2_l.
    (* (3) *)
    rewrite -mulnA divnMl; last done.
    rewrite [(n.-1)`! * n`!]mulnC.

    (* RHS *)
    (* (1) *)
    rewrite bin_factd; last by rewrite double_gt0.
    have -> : n.*2 - n.+1 = n.-1 by rewrite -addnn; ssromega.
    rewrite [n.+1`!]factS.
    (* (2) *)
    rewrite muln_divA; last by rewrite divn_n2_r.
    (* (3) *)
    rewrite -mulnA divnMl; last done.

    done.
  Qed.

End TH.

(**
# おまけ

カタラン数には、漸化式を使った表現もあります。これが一致することを証明できるでしょうか。
*)

Section DEFINE.

  Definition catalan n := 'C(n.*2, n) %/ n.+1.

  Compute catalan 0.                          (* 1 *)
  Compute catalan 1.                          (* 1 *)
  Compute catalan 2.                          (* 2 *)
  Compute catalan 3.                          (* 5 *)

  Fixpoint catalan_rec n {struct n} :=
    match n with
    | 0 => 1
    | n'.+1 => \sum_(0 <= i < n'.+1)(catalan_rec (n' - (i + n')) * catalan_rec (n' - i))
    end.

(**
停止性が判定できるように、``i`` でよいところを ``n' - (i + n')`` としています。。。。
*)
  Compute catalan_rec 0.
  Compute catalan_rec 1.
  Compute catalan_rec 2.

End DEFINE.

(**
# 文献

[1] https://ja.wikipedia.org/wiki/カタラン数

[2] https://www.google.com/search?&q=カタラン数を語らん
*)

(* END *)


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear4.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_paralleldef2A :
   forall A B C D,
   TP A B C D ->
   Par A B C D.
Proof.
intros.
assert ((neq A B /\ neq C D /\ ~ Meet A B C D /\ OS C D A B)) by (conclude_def TP ).
let Tf:=fresh in
assert (Tf:exists a b e, (Col A B a /\ Col A B b /\ BetS C a e /\ BetS D b e /\ nCol A B C /\ nCol A B D)) by (conclude_def OS );destruct Tf as [a[b[e]]];spliter.
assert (Col C a e) by (conclude_def Col ).
assert (Col D b e) by (conclude_def Col ).
assert (neq a e) by (forward_using lemma_betweennotequal).
assert (neq e a) by (conclude lemma_inequalitysymmetric).
assert (neq C e) by (forward_using lemma_betweennotequal).
assert (neq e C) by (conclude lemma_inequalitysymmetric).
assert (neq D e) by (forward_using lemma_betweennotequal).
assert (neq e D) by (conclude lemma_inequalitysymmetric).
assert (~ eq a b).
 {
 intro.
 assert (Col D a e) by (conclude cn_equalitysub).
 assert (Col a e C) by (forward_using lemma_collinearorder).
 assert (Col a e D) by (forward_using lemma_collinearorder).
 assert (Col e C D) by (conclude lemma_collinear4).
 assert (Col e D C) by (forward_using lemma_collinearorder).
 assert (Col e D b) by (forward_using lemma_collinearorder).
 assert (Col D C b) by (conclude lemma_collinear4).
 assert (Col C D b) by (forward_using lemma_collinearorder).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ Col C e D).
 {
 intro.
 assert (Col C e a) by (forward_using lemma_collinearorder).
 assert (Col e D a) by (conclude lemma_collinear4).
 assert (Col e D b) by (forward_using lemma_collinearorder).
 assert (Col D a b) by (conclude lemma_collinear4).
 assert (Col e D C) by (forward_using lemma_collinearorder).
 assert (Col D C a) by (conclude lemma_collinear4).
 assert (Col C D a) by (forward_using lemma_collinearorder).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists M, (BetS C M b /\ BetS D M a)) by (conclude postulate_Pasch_inner);destruct Tf as [M];spliter.
assert (BetS a M D) by (conclude axiom_betweennesssymmetry).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col C D C) by (conclude_def Col ).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (Col C D D) by (conclude_def Col ).
assert (Par A B C D) by (conclude_def Par ).
close.
Qed.

End Euclid.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Nnat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Arith_base.
Require Import Compare_dec.
Require Import Sumbool.
Require Import Div2.
Require Import Min.
Require Import Max.
Require Import BinPos.
Require Import BinNat.
Require Import BinInt.
Require Import Pnat.
Require Import Zmax.
Require Import Zmin.
Require Import Znat.

(** Translation from [N] to [nat] and back. *)

Definition nat_of_N (a:N) :=
  match a with
  | N0 => 0%nat
  | Npos p => nat_of_P p
  end.

Definition N_of_nat (n:nat) :=
  match n with
  | O => N0
  | S n' => Npos (P_of_succ_nat n')
  end.

Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N a) = a.
Proof.
  destruct a as [| p]. reflexivity.
  simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *.
  rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H.
  rewrite nat_of_P_inj with (1 := H). reflexivity.
Qed.

Lemma nat_of_N_of_nat : forall n:nat, nat_of_N (N_of_nat n) = n.
Proof.
  induction n. trivial.
  intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ.
Qed.

(** Interaction of this translation and usual operations. *)

Lemma nat_of_Ndouble : forall a, nat_of_N (Ndouble a) = 2*(nat_of_N a).
Proof.
  destruct a; simpl nat_of_N; auto.
  apply nat_of_P_xO.
Qed.

Lemma N_of_double : forall n, N_of_nat (2*n) = Ndouble (N_of_nat n).
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  rewrite <- nat_of_Ndouble.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Ndouble_plus_one :
  forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)).
Proof.
  destruct a; simpl nat_of_N; auto.
  apply nat_of_P_xI.
Qed.

Lemma N_of_double_plus_one :
  forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n).
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  rewrite <- nat_of_Ndouble_plus_one.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Nsucc : forall a, nat_of_N (Nsucc a) = S (nat_of_N a).
Proof.
  destruct a; simpl.
  apply nat_of_P_xH.
  apply nat_of_P_succ_morphism.
Qed.

Lemma N_of_S : forall n, N_of_nat (S n) = Nsucc (N_of_nat n).
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  rewrite <- nat_of_Nsucc.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Nplus :
  forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a').
Proof.
  destruct a; destruct a'; simpl; auto.
  apply nat_of_P_plus_morphism.
Qed.

Lemma N_of_plus :
  forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n').
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
  rewrite <- nat_of_Nplus.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Nminus :
  forall a a', nat_of_N (Nminus a a') = ((nat_of_N a)-(nat_of_N a'))%nat.
Proof.
  destruct a; destruct a'; simpl; auto with arith.
  case_eq (Pcompare p p0 Eq); simpl; intros.
  rewrite (Pcompare_Eq_eq _ _ H); auto with arith.
  rewrite Pminus_mask_diag. simpl. apply minus_n_n.
  rewrite Pminus_mask_Lt. pose proof (nat_of_P_lt_Lt_compare_morphism _ _ H). simpl.
  symmetry; apply not_le_minus_0. auto with arith. assumption.
  pose proof (Pminus_mask_Gt p p0 H) as H1. destruct H1 as [q [H1 _]]. rewrite H1; simpl.
  replace q with (Pminus p p0) by (unfold Pminus; now rewrite H1).
  apply nat_of_P_minus_morphism; auto.
Qed.

Lemma N_of_minus :
  forall n n', N_of_nat (n-n') = Nminus (N_of_nat n) (N_of_nat n').
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
  rewrite <- nat_of_Nminus.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Nmult :
  forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a').
Proof.
  destruct a; destruct a'; simpl; auto.
  apply nat_of_P_mult_morphism.
Qed.

Lemma N_of_mult :
  forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n').
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
  rewrite <- nat_of_Nmult.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Ndiv2 :
  forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a).
Proof.
  destruct a; simpl in *; auto.
  destruct p; auto.
  rewrite nat_of_P_xI.
  rewrite div2_double_plus_one; auto.
  rewrite nat_of_P_xO.
  rewrite div2_double; auto.
Qed.

Lemma N_of_div2 :
  forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n).
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  rewrite <- nat_of_Ndiv2.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Ncompare :
 forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a').
Proof.
  destruct a; destruct a'; simpl.
  reflexivity.
  assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P.
  destruct nat_of_P; [inversion NZ|auto].
  assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P.
  destruct nat_of_P; [inversion NZ|auto].
  apply nat_of_P_compare_morphism.
Qed.

Lemma N_of_nat_compare :
 forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n').
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
  symmetry; apply nat_of_Ncompare.
Qed.

Lemma nat_of_Nmin :
  forall a a', nat_of_N (Nmin a a') = min (nat_of_N a) (nat_of_N a').
Proof.
  intros; unfold Nmin; rewrite nat_of_Ncompare.
  rewrite nat_compare_equiv; unfold nat_compare_alt.
  destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|];
    simpl; intros; symmetry; auto with arith.
  apply min_l; rewrite e; auto with arith.
Qed.

Lemma N_of_min :
  forall n n', N_of_nat (min n n') = Nmin (N_of_nat n) (N_of_nat n').
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
  rewrite <- nat_of_Nmin.
  apply N_of_nat_of_N.
Qed.

Lemma nat_of_Nmax :
  forall a a', nat_of_N (Nmax a a') = max (nat_of_N a) (nat_of_N a').
Proof.
  intros; unfold Nmax; rewrite nat_of_Ncompare.
  rewrite nat_compare_equiv; unfold nat_compare_alt.
  destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|];
    simpl; intros; symmetry; auto with arith.
  apply max_r; rewrite e; auto with arith.
Qed.

Lemma N_of_max :
  forall n n', N_of_nat (max n n') = Nmax (N_of_nat n) (N_of_nat n').
Proof.
  intros.
  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
  rewrite <- nat_of_Nmax.
  apply N_of_nat_of_N.
Qed.

(** Properties concerning [Z_of_N] *)

Lemma Z_of_nat_of_N : forall n:N, Z_of_nat (nat_of_N n) = Z_of_N n.
Proof.
  destruct n; simpl; auto; symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P.
Qed.

Lemma Z_of_N_eq : forall n m, n = m -> Z_of_N n = Z_of_N m.
Proof.
 intros; f_equal; assumption.
Qed.

Lemma Z_of_N_eq_rev : forall n m, Z_of_N n = Z_of_N m -> n = m.
Proof.
 intros [|n] [|m]; simpl; intros; try discriminate; congruence.
Qed.

Lemma Z_of_N_eq_iff : forall n m, n = m <-> Z_of_N n = Z_of_N m.
Proof.
 split; [apply Z_of_N_eq | apply Z_of_N_eq_rev].
Qed.

Lemma Z_of_N_le : forall n m, (n<=m)%N -> (Z_of_N n <= Z_of_N m)%Z.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_le_rev : forall n m, (Z_of_N n <= Z_of_N m)%Z -> (n<=m)%N.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_le_iff : forall n m, (n<=m)%N <-> (Z_of_N n <= Z_of_N m)%Z.
Proof.
 split; [apply Z_of_N_le | apply Z_of_N_le_rev].
Qed.

Lemma Z_of_N_lt : forall n m, (n<m)%N -> (Z_of_N n < Z_of_N m)%Z.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_lt_rev : forall n m, (Z_of_N n < Z_of_N m)%Z -> (n<m)%N.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_lt_iff : forall n m, (n<m)%N <-> (Z_of_N n < Z_of_N m)%Z.
Proof.
 split; [apply Z_of_N_lt | apply Z_of_N_lt_rev].
Qed.

Lemma Z_of_N_ge : forall n m, (n>=m)%N -> (Z_of_N n >= Z_of_N m)%Z.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_ge_rev : forall n m, (Z_of_N n >= Z_of_N m)%Z -> (n>=m)%N.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_ge_iff : forall n m, (n>=m)%N <-> (Z_of_N n >= Z_of_N m)%Z.
Proof.
 split; [apply Z_of_N_ge | apply Z_of_N_ge_rev].
Qed.

Lemma Z_of_N_gt : forall n m, (n>m)%N -> (Z_of_N n > Z_of_N m)%Z.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_gt_rev : forall n m, (Z_of_N n > Z_of_N m)%Z -> (n>m)%N.
Proof.
 intros [|n] [|m]; simpl; auto.
Qed.

Lemma Z_of_N_gt_iff : forall n m, (n>m)%N <-> (Z_of_N n > Z_of_N m)%Z.
Proof.
 split; [apply Z_of_N_gt | apply Z_of_N_gt_rev].
Qed.

Lemma Z_of_N_of_nat : forall n:nat, Z_of_N (N_of_nat n) = Z_of_nat n.
Proof.
 destruct n; simpl; auto.
Qed.

Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p.
Proof.
 destruct p; simpl; auto.
Qed.

Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z.
Proof.
 destruct z; simpl; auto.
Qed.

Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z.
Proof.
 destruct n; intro; discriminate.
Qed.

Lemma Z_of_N_plus : forall n m:N, Z_of_N (n+m) = (Z_of_N n + Z_of_N m)%Z.
Proof.
 destruct n; destruct m; auto.
Qed.

Lemma Z_of_N_mult : forall n m:N, Z_of_N (n*m) = (Z_of_N n * Z_of_N m)%Z.
Proof.
 destruct n; destruct m; auto.
Qed.

Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m).
Proof.
 intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nminus; apply inj_minus.
Qed.

Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n).
Proof.
 intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S.
Qed.

Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m).
Proof.
 intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min.
Qed.

Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m).
Proof.
 intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmax; apply inj_max.
Qed.


Require Import ELambda.Definitions.

Require Import Lambda.Syntax.
Require Import LambdaJm.Syntax.
Require Import LambdaJm.Reduction.

Module S := ELambda.Definitions.
Module L := LambdaJm.Syntax.

Import S.ELambdaNotations.
Import L.LambdaJmNotations.

Lemma beta_preserves_il t1 t2 : is_lambda t1 -> betaT t1 t2 -> is_lambda t2.
  intros.
  induction H0.
  - induction H0. inversion H. cbn.
    inversion H5. apply open_preserves_il; trivial.
  - induction H0. inversion H.
Qed.

Lemma sim_by_beta_term : forall e1 e2,
    beta e1 e2 -> beta1T (exp_to_terms e1) (exp_to_terms e2).
Proof.
   intros. inversion H. simpl.  subst. rewrite  commut_opens. constructor.
   - constructor. intro. inversion H0.
     change ( lcT (openT (exp_to_terms e0) (exp_to_terms (S.var_f x)))).
     rewrite <- commut_opens. specialize H3 with x. apply lcT_from_lc_exp. trivial.
   - apply lcT_from_lc_exp. trivial.
   - constructor. intro. cbn.  trivial.
Qed.

Theorem term_to_exp_preserves_beta1: forall t u,
forall (H1:is_lambda t) (H2:is_lambda u),
beta1T t u -> beta (term_to_exp t H1) (term_to_exp u H2).
Proof.
  intros e1 e2 H1 H2 H. induction H. inversion H1; subst.
  unfold open_term_wrt_term in *. simpl in *. inversion H6; subst.
  rewrite (term_to_exp_commutes_open u t
                                     (il_app_inv2 (abs t) u H1)
                                     (il_abs_inv t (il_app_inv1 (abs t) u H1))).
  apply beta_base.
  - apply S.lc_abs. intro x.
    change (S.lc_exp (open
                        ((term_to_exp t) (il_abs_inv t (il_app_inv1 (abs t) u H1)))
                        (term_to_exp (L.var_f x) (il_var_f x)))).
    unfold open_exp_wrt_exp.
    rewrite <- (term_to_exp_commutes_open _ _ _ _ 0 (open_preserves_il (L.var_f x)
                                                                    t (il_var_f x) H5 0)).
    apply term_to_exp_preserves_lc. inversion H. apply H7.
  - apply term_to_exp_preserves_lc. apply H0.
Qed.

Theorem sim_by_ccbeta_term : forall (e1 e2:exp),
    S.ccBeta e1 e2 -> ccBeta1T  (exp_to_terms e1) (exp_to_terms e2).
Proof.
  intros. induction H.
  - intros. constructor. apply sim_by_beta_term. assumption.
  - simpl. apply cc_app1.
    + constructor;eauto.
      * eapply lcT_from_lc_exp. assumption.
      * constructor. intro. cbn. auto.
    + fold ccBeta1T. assumption.
  - simpl. apply cc_app2.
    + eapply lcT_from_lc_exp. assumption.
    + constructor; eauto. constructor. intro. cbn. auto.
  - simpl. apply cc_abs with (L:=L). intros.
    change (ccRTT beta1T (openT (exp_to_terms e1) (exp_to_terms (S.var_f x)))
                  (openT (exp_to_terms e2) (exp_to_terms (S.var_f x)))).
    repeat (rewrite <- commut_opens).  fold ccBeta1T.  specialize (H0 x). auto.
Qed.


Require Import Events.
Require Import ClassicalExtras.
Require Import TraceModel.
Require Import Properties.
Require Import FunctionalExtensionality.
Require Import Coq.Logic.ClassicalFacts.

(** This file describes the topology of the classes of
    properties *)

Axiom prop_ext : prop_extensionality.

Record Topology {X : Set} :=
  {
    open : (X -> Prop) -> Prop;
    empty : open (fun x : X => False);
    full  : open (fun x : X => True);

    arbitrary_union :
      forall (F : (X -> Prop) -> Prop),
        (forall f, F f -> open f) ->
         open (fun x : X => exists f, F f /\ f x);

    finite_intersection :
      forall A1 A2, open A1 -> open A2 ->
       open (fun x : X => A1 x /\ A2 x)
  }.

Definition closed {X : Set} (τ : @Topology X) :
                  (X -> Prop) -> Prop :=
  (fun C => (open τ) (fun x => (~ C x))).

Lemma arbitrary_intersection {X : Set} (τ : @Topology X) :
   forall (F : (X -> Prop) -> Prop),
        (forall f, F f -> (closed τ) f) ->
        (closed τ) (fun x : X => (forall f, F f -> f x)).
Proof.
  unfold closed. intros F H.
  specialize (arbitrary_union τ (fun f =>  F (fun x => ~ f x))).
  assert ((forall f : X -> Prop,
              (fun f0 : X -> Prop =>
                 F (fun x : X => ~ f0 x)) f -> open τ f)).
  { intros f H0. specialize (H (fun x => ~ f x) H0).
    simpl in H. assert (f = (fun x => ~ ~ f x)).
    apply functional_extensionality. intros x.
    apply (prop_ext). now rewrite <- dne.
    now rewrite H1. }
  intros H1. specialize (H1 H0).
  assert ( (fun x : X =>
          exists f : X -> Prop,
            (fun f0 : X -> Prop =>
             F (fun x0 : X => ~ f0 x0)) f /\
            f x)  =
         (fun x : X => ~ (forall f : X -> Prop, F f -> f x)
         )).
  { apply functional_extensionality. intros x. apply prop_ext.
    rewrite not_forall_ex_not. split.
    + intros [f [K1 K2]]. exists (fun x => ~ f x). rewrite not_imp.
      split; now auto.
    + intros [f K]. exists (fun x => ~ f x). split; try now auto.
      rewrite not_imp in K. destruct K as [k1 k2].
      assert (f = fun x0 => ~ ~ f x0).
      { apply functional_extensionality. intros x0.
        apply prop_ext. now rewrite <- dne. }
      now rewrite <- H2. }
  now rewrite <- H2.
Qed.

Lemma finite_union {X : Set} (τ : @Topology X) :
  forall C1 C2, (closed τ) C1 -> (closed τ) C2 ->
           (closed τ) (fun x => C1 x \/ C2 x).
Proof.
  unfold closed. intros C1 C2 H1 H2.
  assert ( (fun x : X => ~ (C1 x \/ C2 x)) = (fun x => ~ C1 x /\ ~ C2 x)).
  { apply functional_extensionality. intros x.
    apply prop_ext. now rewrite de_morgan2. }
  rewrite H. now apply (finite_intersection τ).
Qed.

Definition closure {X : Set} (S : X -> Prop) (τ : @Topology X) :=
  fun x => (forall C, (closed τ) C -> (forall y, S y -> C y) -> C x).

Lemma closure_is_closed {X : Set} (τ : @Topology X) :
  forall S, (closed τ) (closure S τ).
Proof.
  intros S. unfold closure.
  specialize (arbitrary_intersection τ
              (fun C => (closed τ) C /\ (forall y, S y -> C y))).
  intros Hint.
  assert (forall K, ((fun C => (closed τ) C /\ (forall y, S y -> C y)) K)
               -> closed τ K) by easy.
  specialize (Hint H); clear H.
  simpl in Hint.
  assert ((fun x : X =>
            forall f : X -> Prop,
            closed τ f /\ (forall y : X, S y -> f y) -> f x)
           =
          (fun x : X =>
            forall C : X -> Prop,
              closed τ C -> (forall y : X, S y -> C y) -> C x)).
  { apply functional_extensionality. intros x.
    apply prop_ext. now firstorder. }
  now rewrite <- H.
Qed.

Lemma closure_includes {X : Set} (S: X -> Prop) (τ : @Topology X) :
  forall x, (S x -> (closure S τ) x).

Proof. unfold closure. now auto. Qed.

Lemma closure_smallest {X : Set} (S : X -> Prop) (τ : @Topology X) :
  forall C, (closed τ) C ->
       (forall x, S x -> C x) ->
       (forall x, (closure S τ) x -> C x).
Proof.
  intros C Hcl Hsub x Hc. now apply Hc.
Qed.

Definition dense {X : Set} (τ : @Topology X) :
                 (X -> Prop) -> Prop :=
  (fun D => forall A, (open τ) A ->
               (exists a, A a) ->
               (exists d, A d /\ D d)).

Lemma not_dense {X : Set} (τ : @Topology X) :
  forall B, ~ (dense τ) B <-> exists A a, A a /\ (open τ) A /\ (forall t, A t -> ~ B t).
Proof.
  unfold dense. intros B. split.
  + rewrite not_forall_ex_not. intros [H h].
    rewrite not_imp in h. destruct h as [h1 h2].
    rewrite not_imp in h2. destruct h2 as [[a Ha] h2].
    rewrite not_ex_forall_not in h2.
    exists H, a. repeat (split; try now auto).
    intros t ht. now firstorder.
  + rewrite not_forall_ex_not. intros [A [a [H1 [H2 H3]]]].
    exists A. intros ff. destruct (ff H2); try now auto.
    now exists a. apply (H3 x); try now auto.
Qed.

Lemma full_closed_and_dense {X : Set} (τ : @Topology X) :
  closed τ (fun x => True) /\
  dense τ (fun x => True).
Proof.
  split.
  - unfold closed.
    assert ((fun x : X => ~ True) = (fun x : X => False)).
    { apply functional_extensionality. intros x.
      apply prop_ext. tauto. } rewrite H.
    apply (empty τ).
  - unfold dense. intros A Hop [a Ha].
    now exists a.
Qed.

Theorem only_full_closed_and_dense {X : Set} (τ : @Topology X) :
  forall S, (closed τ S /\ dense τ S) <-> (forall x, S x).
Proof.
  intros S. split.
  - intros [Hc Hd]. apply NNPP. rewrite not_forall_ex_not.
    intros [a H].
    assert (open τ (fun x => ~ S x)). now apply Hc.
    destruct (Hd (fun x => ~ S x)); try now auto. now exists a.
  - intros Hfull. assert (S = fun x => True). { apply functional_extensionality.
    intros x. now apply prop_ext. } rewrite H.
    now apply full_closed_and_dense.
Qed.

Lemma s_dense {X : Set} (S : X -> Prop) (τ : @Topology X) :
  (dense τ) (fun x => ~ ((closure S τ) x /\ ~ S x)).
Proof.
  apply NNPP. rewrite not_dense. intros [A [a [Ha [Hop H]]]].
  assert (Hincl1 : forall t, A t -> closure S τ t /\ ~ S t).
  { intros t H0. apply NNPP. now auto. }
  assert (Hincl2 : forall t, S t -> (closure S τ t /\ ~ A t)).
  { intros t H0. split.
    + now apply closure_includes.
    + intros ff. specialize (Hincl1 t ff). specialize (H t ff).
      now auto. }
  assert (contr : ~ (forall C, (closed τ C) -> (forall b, S b -> C b) ->
                          (forall t, (closure S τ) t -> C t))).
  { intros ff.
    assert (A = fun x => ~ ~ A x).
    { apply functional_extensionality. intros x.
      apply prop_ext. now rewrite <- dne. }
    assert (closed τ (fun x => ~ A x)).
    { unfold closed. now rewrite <- H0. }
    assert (forall b, S b -> (fun x => ~ A x) b) by now firstorder.
    specialize (ff (fun x => ~ A x) H1 H2).
    simpl in *. destruct (Hincl1 a Ha) as [k1 k2].
    now apply (ff a k1). }
    apply contr. now apply closure_smallest.
Qed.

Theorem decomposition_theorem {X : Set} (τ : @Topology X) :
  forall S, (exists C D, closed τ C /\ dense τ D /\
               (forall x, S x <-> (C x  /\ D x))).
Proof.
  intros S. exists (closure S τ), (fun x => ~ ((closure S τ) x /\ ~ S x)).
  split.
  - now apply closure_is_closed.
  - split.
    + now apply  s_dense.
    + intros x. split.
      ++ intros Hs. split.
         * now apply closure_includes.
         * now firstorder.
      ++ intros [Hc Hconj]. rewrite de_morgan1 in Hconj.
         destruct Hconj; try now auto. now rewrite dne.
Qed.

Lemma dense_closure_true (X : Set)
                         (τ : @Topology X)
                         (D : X -> Prop) :
  (forall x : X, (closure D τ) x) -> dense τ D.
Proof.
  intros H_closure A HA [a Aa].
  apply NNPP. intros Hf. rewrite not_ex_forall_not in Hf.
  assert (H_meet : forall t, D t -> (fun t => ~ A t) t).
  { intros t. specialize (Hf t). rewrite de_morgan1 in Hf.
    intros Hdt. now destruct Hf. }
  assert (HC : closed τ (fun t0 => ~ A t0)).
  { unfold closed. assert ((fun x : X => ~ ~ A x) = A).
    apply functional_extensionality. intros x.
    apply prop_ext. symmetry. now apply dne.
    now rewrite H. }
  specialize (closure_smallest D τ (fun t0 => ~ A t0) HC H_meet).
  intros ff. specialize (H_closure a). specialize (ff a H_closure).
  now simpl in ff.
Qed.


Require Export Lattice.PartialOrder Lattice.MLattice.

Local Open Scope lattice_scope.

(** An ultra metric space is a metric space where triangular inequality:
     ∀ x y, δ(x, z) ≤ δ(x, y) + δ(y, z)
is replaced with ultrametric inequality:
     ∀ x y, δ(x, z) ≤ max{δ(x, y), δ(y, z)}
*)
Record UltraMetric (L : MLattice) : Type :=
  {
    UM_Carrier :> Type;
    UM_distance : UM_Carrier → UM_Carrier → L where "δ( x , y )" := (UM_distance x y);
    UM_dist_sym : ∀ x y, δ(x, y) = δ(y, x);
    UM_eq_zero_dist :
      ∀ x, (δ(x, x) = ⊥);
    UM_zero_dist_eq :
      ∀ x y, (δ(x, y) = ⊥) → x = y;
    UM_ineq : ∀ x z y, (δ(x, z) ⊑ (δ(x, y) ⊔ δ(y, z))%lattice)%order
  }.

Arguments UM_Carrier {_} _ : assert.
Arguments UM_distance {_ _} _ _.

Notation "δ( x , y )" := (UM_distance x y) : metric_scope.

(** A sequence is a function from natural numbers to the metric space. *)
Definition Sequence {L : MLattice} (U : UltraMetric L) := nat → U.

Identity Coercion Sq : Sequence >-> Funclass.


Require Import GHC.Base.
Import GHC.Base.Notations.
Require Import Proofs.GHC.Base.
Require Import Data.Map.Internal.
Import GHC.Num.Notations.
Require Import OrdTactic.
Require Import Psatz.
Require Import Tactics.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.

Section WF.
Context {e : Type} {a : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [lookup] *)

Lemma lookup_spec:
 forall (s: Map e a) lb ub i, Bounded s lb ub -> lookup i s = sem s i.
Proof.
  intros ???? HB.
  induction HB.
  * simpl. reflexivity.
  * subst; simpl.
    destruct (compare i x) eqn:?.
    + replace (i == x) with true by order_Bounds e.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      reflexivity.
    + replace (i == x) with false by order_Bounds e.
      rewrite IHHB1.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      simpl_options.
      reflexivity.
    + replace (i == x) with false by order_Bounds e.
      rewrite IHHB2.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      simpl_options.
      reflexivity.
Qed.

(** ** Verification of [member] *)

Lemma member_spec:
 forall (s: Map e a) lb ub i, Bounded s lb ub -> member i s = true <-> exists v, sem s i = Some v.
Proof.
  intros. induction H.
  - simpl. split. intros. discriminate H. intros. destruct H. discriminate H.
  - subst. simpl. destruct (compare i x) eqn: ?; split; intros.
    + replace (i==x) with true by order_Bounds e.
      rewrite (sem_outside_above H) by order_Bounds e.
      simpl. exists v. reflexivity.
    + reflexivity.
    + replace (i==x) with false by order_Bounds e.
      rewrite (sem_outside_below H0) by order_Bounds e.
      simpl_options. apply IHBounded1 in H3. destruct H3. exists x0. assumption.
    + assert (sem s2 i = None). { eapply sem_outside_below. apply H0. unfold isLB.
      order_Bounds e. }
      rewrite H5 in H3. assert (i == x = false). { rewrite compare_Lt in Heqc.
      apply lt_not_eq. assumption. } rewrite H6 in H3. simpl in H3. simpl_options.
      apply IHBounded1. destruct H3. exists x0. assumption.
    + replace (i==x) with false by order_Bounds e.
      rewrite (sem_outside_above H) by order_Bounds e.
      simpl. apply IHBounded2 in H3. destruct H3. exists x0. assumption.
    + assert (sem s1 i = None). { eapply sem_outside_above. apply H. order_Bounds e. }
      rewrite H5 in H3. rewrite compare_Gt in Heqc. apply gt_not_eq in Heqc. rewrite Heqc in H3.
      simpl_options. destruct H3. apply IHBounded2. exists x0. assumption.
Qed.

(** ** Verification of [notMember] *)

Lemma notMember_spec:
 forall (s: Map e a) lb ub i, Bounded s lb ub -> notMember i s = true <-> sem s i = None.
Proof.
  intros ???? HB.
  unfold notMember, op_zd__. split; intros.
  pose proof (@member_spec s lb ub i). apply H0 in HB. destruct HB. apply contrapositive in H2.
  unfold not in H2. destruct (sem s i). destruct H2. exists a0. reflexivity. reflexivity.
  rewrite negb_true_iff in H. intro. rewrite H3 in H. inversion H.
  pose proof (@member_spec s lb ub i). apply H0 in HB. destruct HB. apply contrapositive in H1.
  rewrite negb_true_iff. destruct (member i s). contradiction. reflexivity. intro.
  destruct H3. rewrite H3 in H. inversion H.
Qed.

(** ** Verification of [findWithDefault] *)
Lemma findWithDefault_spec:
  forall (m: Map e a) lb ub i v, Bounded m lb ub ->
  Some (findWithDefault v i m) = sem m i ||| Some v.
Proof.
  intros. induction H.
  - simpl. reflexivity.
  - simpl. destruct (compare i x) eqn : ?.
    + assert (sem s1 i = None). { eapply sem_outside_above. eassumption. solve_Bounds e. }
      rewrite H5. assert (i == x = true) by (order e). rewrite H6. reflexivity.
    + assert (i == x = false) by (order e). assert (sem s2 i = None). { eapply sem_outside_below.
      eassumption. solve_Bounds e. } rewrite H5. rewrite H6. simpl. rewrite oro_None_r.
      rewrite oro_None_r. apply IHBounded1.
    + assert (i == x = false) by (order e). assert (sem s1 i = None). { eapply sem_outside_above.
      eassumption. solve_Bounds e. } rewrite H5. rewrite H6. simpl. apply IHBounded2.
Qed.
(** ** Verification of [lookupLT] *)
Fixpoint goJustLT k  (k1: e) v1 (m : Map e a) : option (e * a) :=
  match m with
  | Tip => Some (k1, v1)
  | Bin sz k2 v2 l r => if (_GHC.Base.<=_ k k2) then goJustLT k k1 v1 l else
    goJustLT k k2 v2 r
  end.
Fixpoint lookupLT' k (m : Map e a) :=
  match m with
  | Tip => None
  | Bin sz k1 v1 l r => if (_GHC.Base.<=_ k k1) then lookupLT' k l else goJustLT k k1 v1 r
  end.

Lemma lookupLT_equiv:
  forall m k,
  lookupLT' k m = lookupLT k m.
Proof.
  intros. unfold lookupLT'. unfold lookupLT. unfold goJustLT. reflexivity.
Qed.

Lemma goJustLT_pres_smaller: forall k k1 v1 m k2 v2 lb ub,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  _GHC.Base.<_ k2 k = true.
Proof.
  intros. generalize dependent k1. revert v1 v2 k2 k. induction H; intros.
  - simpl in H1. inversion H1; subst. assumption.
  - simpl in H6. destruct (_GHC.Base.<=_ k x) eqn : ?.
   + eapply IHBounded1. eassumption. eassumption.
   + assert (_GHC.Base.<_ x k = true) by (order e). eapply IHBounded2. apply H7.
      apply H6.
Qed.

Lemma goJustLT_bounded: forall k k1 v1 m k2 v2 lb ub l u,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  (lb = Some l /\ _GHC.Base.<=_ l k1 = true -> _GHC.Base.<=_ l k2 = true )
  /\ (ub = Some u /\ _GHC.Base.<=_ k1 u = true -> _GHC.Base.<=_ k2 u = true).
Proof.
  intros. generalize dependent k1. revert k v1 k2 v2 u l. induction H; intros.
  - simpl in H1. inversion H1; subst. split; intros; subst; solve_Bounds e.
  - simpl in H6. destruct (_GHC.Base.<=_ k x) eqn : ?.
    + split; intros; subst.  specialize (IHBounded1 _ _ _ _ u l _ H5 H6). destruct IHBounded1.
       apply H3. apply H7. specialize (IHBounded1 _ _ _ _ x l  _ H5 H6). destruct IHBounded1.
        destruct H7; subst. assert (Some x = Some x /\ _GHC.Base.<=_ k1 x = true).
        split. reflexivity. order e. apply H8 in H7.  assert (compare x u = Lt) by (solve_Bounds e).
        order e.
    + assert (_GHC.Base.<_ x k = true) by (order e).  split; intros; subst.
      specialize (IHBounded2  _ _ _ _ u x _ H7 H6). destruct IHBounded2.
      destruct H8; subst. assert (_GHC.Base.<=_ x k2 = true). apply H3. split. reflexivity.
      order e. assert (_GHC.Base.<_ l x = true) by (solve_Bounds e). order e.
      specialize (IHBounded2 _ _ _ _ u l _ H7 H6). destruct IHBounded2. apply H9.
      split. apply H8. destruct H8. subst. solve_Bounds e.
Qed.

Lemma goJustLT_nothing_between: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  (forall i, compare k2 i = Lt /\ compare i k = Lt ->
  sem m i = None).
Proof.
  intros. generalize dependent i. generalize dependent k2. generalize dependent k1.
  revert k v1 v2.
  induction H; intros.
  - reflexivity.
  - simpl. simpl in H6. destruct ( _GHC.Base.<=_ k x) eqn : ?.
    + assert (i == x = false) by (order e). rewrite H8. assert (sem s2 i = None). {
      eapply sem_outside_below. eassumption. solve_Bounds e. } rewrite H9.
      simpl. repeat(rewrite oro_None_r). eapply IHBounded1. apply H5. apply H6.
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLT_bounded. specialize (H9 _ _ _ _ _ _ _ _ x k H0 H8 H6).
      destruct H9. assert (_GHC.Base.<=_ x k2 = true). apply H9. split. reflexivity.
      order e. assert (_GHC.Base.<_ x i = true). order e. assert (sem s1 i = None).
      eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H13.
      assert (i == x = false) by (order e). rewrite H14. simpl. eapply IHBounded2.
      apply H8. apply H6. apply H7.
Qed.

Lemma goJustLT_finds_upper_bound: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
   (_GHC.Base.<_  k2 k = true) /\
  (forall k3, (_GHC.Base.<_  k3 k = true) /\ (k2 == k3 = false) /\
  sem m k3 <> None -> (_GHC.Base.<_  k3 k2 = true)).
Proof.
  intros. pose proof (goJustLT_nothing_between k k1 v1 m lb ub k2 v2 H H0 H1).
  split. eapply goJustLT_pres_smaller. apply H. apply H0. apply H1. intros.
  specialize (H2 k3). destruct H3. destruct H4.
  destruct (_GHC.Base.<_ k3 k2 ) eqn : ?.
  - reflexivity.
  - assert (sem m k3 = None). apply H2. split. order e. order e. contradiction.
Qed.

Lemma goJustLt_val_in_map: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  sem m k2 = Some v2 \/ ((k2 == k1 = true) /\ v2 = v1).
Proof.
  intros. generalize dependent k2. revert k k1 v1 v2. induction H; intros.
  - simpl in H0. inversion H0; subst. right. split. apply Eq_Reflexive. reflexivity.
  - simpl. simpl in H5. destruct (_GHC.Base.<=_ k x) eqn : ?.
    + specialize (IHBounded1 k k1 v1 v2 k2 H5). destruct IHBounded1.
      * rewrite H6. simpl. left. reflexivity.
      * right. apply H6.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLT_bounded. specialize (H7 k x v s2 k2 v2 (Some x) ub x k H0 H6 H5).
      destruct H7. assert (_GHC.Base.<=_ x k2 = true). apply H7. split. reflexivity. order e.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H10.
      simpl. specialize (IHBounded2 k x v v2 k2 H5). destruct IHBounded2.
      * assert (k2 == x = false) by (solve_Bounds e). rewrite H12. simpl. left.
        assumption.
      * destruct H11.  left. rewrite H11. simpl. subst. reflexivity.
Qed.

Lemma goJustLt_never_none: forall k k1 v1 m,
  goJustLT k k1 v1 m <> None.
Proof.
  intros. revert k k1 v1. induction m; intros.
  - simpl. destruct (_GHC.Base.<=_ k0 k ). apply IHm1. apply IHm2.
  - simpl. intro contra. discriminate contra.
Qed.

(*Part 1 of the spec: If lookupLT returns a k1, v1 pair, then (k1, v1) is in the map
  and k1 is the largest key smaller than k*)
Lemma lookupLT_spec_Some:
  forall (m: Map e a) lb ub k (k1: e) v1, Bounded m lb ub ->
  lookupLT k m = Some (k1, v1) ->
  sem m k1 = Some v1 /\ (_GHC.Base.<_  k1 k = true) /\
  (forall k2, (_GHC.Base.<_  k2 k = true) /\ (k1 == k2 = false) /\
  sem m k2 <> None -> (_GHC.Base.<_  k2 k1 = true)).
Proof.
  intros. rewrite <- lookupLT_equiv in H0. generalize dependent k. revert k1 v1. induction H; intros; split; intros.
  - inversion H0.
  - inversion H0.
  - simpl in H5. simpl. destruct (_GHC.Base.<=_  k x) eqn : ?.
    + apply IHBounded1 in H5. destruct H5. rewrite H5. simpl. reflexivity.
    + assert ( _GHC.Base.<_ x k = true) by (order e).
      pose proof (goJustLT_finds_upper_bound k x v s2 (Some x) ub k1 v1 H0 H6 H5).
      destruct H7. specialize (H8 x).
      pose proof (goJustLt_val_in_map k x v s2 (Some x) ub k1 v1 H0 H5).
      pose proof goJustLT_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity. order e.
      assert (sem s1 k1 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H13. simpl. destruct H9.
      * assert (k1 == x = false) by (solve_Bounds e). rewrite H14. simpl. assumption.
      * destruct H9. subst. rewrite H9. reflexivity.
  - simpl in H5. destruct (_GHC.Base.<=_ k x) eqn : ?.
    + simpl. specialize (IHBounded1 k1 v1 k H5). destruct IHBounded1. destruct H7. split.
      assumption. intros. apply H8. destruct H9. destruct H10.
      split. assumption. split. assumption. assert (k2 == x = false) by (order e).
      assert (sem s2 k2 = None). eapply sem_outside_below. eassumption. solve_Bounds e.
      rewrite H13 in H11. rewrite H12 in H11. simpl in H11. repeat (rewrite oro_None_r in H11).
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e). split. eapply goJustLT_pres_smaller. apply H0.
      apply H6. apply H5. intros. destruct H7. destruct H8. simpl in H9.
      pose proof goJustLT_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity.
      order e. destruct (compare k2 k1) eqn : ?.
      order e.
      order e.
      assert (k2 == x = false) by (order e). rewrite H13 in H9. simpl in H9.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H14 in H9. simpl in H9. eapply goJustLT_finds_upper_bound.
       apply H0. apply H6. apply H5. split; try(assumption); split; assumption.
Qed.

(*Part 2: If lookupLT returns None, then every key in the map is smaller than k*)
Lemma lookupLT_spec_None:
  forall (m: Map e a) lb ub k, Bounded m lb ub ->
  lookupLT k m = None ->
  (forall k2 v2, sem m k2 = Some v2 -> _GHC.Base.<=_ k k2 = true).
Proof.
  intros. generalize dependent k2. generalize dependent k. revert v2. induction H; intros.
  - inversion H1.
  - rewrite <- lookupLT_equiv in H5. simpl in H5. destruct (_GHC.Base.<=_ k x) eqn : ?.
    simpl in H6. destruct (sem s1 k2) eqn : ?.
    * simpl in H6; inversion H6; subst. eapply IHBounded1. apply H5. apply Heqo.
    * simpl in H6. destruct (k2 == x) eqn : ?.
      -- order e.
      -- simpl in H6. solve_Bounds e.
    * assert (goJustLT k x v s2 <> None). apply goJustLt_never_none. rewrite H5 in H7.
      contradiction.
Qed.

(** ** Verification of [lookupLE] *)
Fixpoint goJustLE k (k1: e) v1 (m : Map e a) : option (e * a) :=
  match m with
  | Tip => Some (k1, v1)
  | Bin sz k2 v2 l r => match compare k k2 with
                        | Lt => goJustLE k k1 v1 l
                        | Eq => Some (k2, v2)
                        | Gt => goJustLE k k2 v2 r
                        end
  end.

Fixpoint lookupLE' k (m : Map e a) :=
  match m with
  | Tip => None
  | Bin sz k1 v1 l r => match compare k k1 with
                        | Lt => lookupLE' k l
                        | Eq => Some (k1, v1)
                        | Gt => goJustLE k k1 v1 r
                        end
  end.

Lemma lookupLE_equiv:
  forall m k,
  lookupLE' k m = lookupLE k m.
Proof.
  intros. unfold lookupLE'. unfold lookupLE. unfold goJustLE. reflexivity.
Qed.

Lemma goJustLE_pres_smaller: forall k k1 v1 m k2 v2 lb ub,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  _GHC.Base.<=_ k2 k = true.
Proof.
  intros. generalize dependent k1. revert v1 v2 k2 k. induction H; intros.
  - simpl in H1. inversion H1; subst. order e.
  - simpl in H6. destruct (compare k x) eqn : ?.
    + inversion H6; subst. order e.
    + eapply IHBounded1. eassumption. eassumption.
    + assert (_GHC.Base.<_ x k = true) by (order e). eapply IHBounded2. apply H7.
      apply H6.
Qed.

Lemma goJustLE_bounded: forall k k1 v1 m k2 v2 lb ub l u,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  (lb = Some l /\ _GHC.Base.<=_ l k1 = true -> _GHC.Base.<=_ l k2 = true )
  /\ (ub = Some u /\ _GHC.Base.<=_ k1 u = true -> _GHC.Base.<=_ k2 u = true).
Proof.
  intros. generalize dependent k1. revert k v1 k2 v2 u l. induction H; intros.
  - simpl in H1. inversion H1; subst. split; intros; subst; solve_Bounds e.
  - simpl in H6. destruct (compare k x) eqn : ?.
    + inversion H6; subst. split; intros. order e. destruct H3. subst. solve_Bounds e.
    + split; intros; subst.  specialize (IHBounded1 _ _ _ _ u l _ H5 H6). destruct IHBounded1.
       apply H3. apply H7. specialize (IHBounded1 _ _ _ _ x l  _ H5 H6). destruct IHBounded1.
        destruct H7; subst. assert (Some x = Some x /\ _GHC.Base.<=_ k1 x = true).
        split. reflexivity. order e. apply H8 in H7.  assert (compare x u = Lt) by (solve_Bounds e).
        order e.
    + assert (_GHC.Base.<_ x k = true) by (order e).  split; intros; subst.
      specialize (IHBounded2  _ _ _ _ u x _ H7 H6). destruct IHBounded2.
      destruct H8; subst. assert (_GHC.Base.<=_ x k2 = true). apply H3. split. reflexivity.
      order e. assert (_GHC.Base.<_ l x = true) by (solve_Bounds e). order e.
      specialize (IHBounded2 _ _ _ _ u l _ H7 H6). destruct IHBounded2. apply H9.
      split. apply H8. destruct H8. subst. solve_Bounds e.
Qed.

Lemma goJustLE_nothing_between: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  (forall i, compare k2 i = Lt /\ compare i k = Lt ->
  sem m i = None).
Proof.
  intros. generalize dependent i. generalize dependent k2. generalize dependent k1.
  revert k v1 v2.
  induction H; intros.
  - reflexivity.
  - simpl. simpl in H6. destruct (compare k x) eqn : ?.
    + assert (i == x = false) by (order e). rewrite H8. assert (sem s2 i = None). {
      eapply sem_outside_below. eassumption. solve_Bounds e. } rewrite H9.
      simpl. repeat(rewrite oro_None_r). inversion H6; subst. eapply sem_outside_above.
      eassumption. solve_Bounds e.
    + assert (i == x = false) by (order e). rewrite H8. assert (sem s2 i = None). {
      eapply sem_outside_below. eassumption. solve_Bounds e. } rewrite H9.
      simpl. repeat(rewrite oro_None_r).  eapply IHBounded1. apply H5. apply H6.
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLE_bounded. specialize (H9 _ _ _ _ _ _ _ _ x k H0 H8 H6).
      destruct H9. assert (_GHC.Base.<=_ x k2 = true). apply H9. split. reflexivity.
      order e. assert (_GHC.Base.<_ x i = true). order e. assert (sem s1 i = None).
      eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H13.
      assert (i == x = false) by (order e). rewrite H14. simpl. eapply IHBounded2.
      apply H8. apply H6. apply H7.
Qed.

Lemma goJustLE_finds_upper_bound: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
   (_GHC.Base.<=_  k2 k = true) /\
  (forall k3, (_GHC.Base.<_  k3 k = true) /\ (k2 == k3 = false) /\
  sem m k3 <> None -> (_GHC.Base.<_  k3 k2 = true)).
Proof.
  intros. pose proof (goJustLE_nothing_between k k1 v1 m lb ub k2 v2 H H0 H1).
  split. eapply goJustLE_pres_smaller. apply H. apply H0. apply H1. intros.
  specialize (H2 k3). destruct H3. destruct H4.
  destruct (_GHC.Base.<_ k3 k2 ) eqn : ?.
  - reflexivity.
  - assert (sem m k3 = None). apply H2. split. order e. order e. contradiction.
Qed.

Lemma goJustLE_val_in_map: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  sem m k2 = Some v2 \/ ((k2 == k1 = true) /\ v2 = v1).
Proof.
  intros. generalize dependent k2. revert k k1 v1 v2. induction H; intros.
  - simpl in H0. inversion H0; subst. right. split. apply Eq_Reflexive. reflexivity.
  - simpl. simpl in H5. destruct (compare k x) eqn : ?.
    + inversion H5; subst. assert (sem s1 k2 = None). eapply sem_outside_above.
      eassumption. solve_Bounds e. rewrite H3. rewrite Eq_Reflexive. simpl.
      left. reflexivity.
    + specialize (IHBounded1 k k1 v1 v2 k2 H5). destruct IHBounded1.
      * rewrite H6. simpl. left. reflexivity.
      * right. apply H6.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLE_bounded. specialize (H7 k x v s2 k2 v2 (Some x) ub x k H0 H6 H5).
      destruct H7. assert (_GHC.Base.<=_ x k2 = true). apply H7. split. reflexivity. order e.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H10.
      simpl. specialize (IHBounded2 k x v v2 k2 H5). destruct IHBounded2.
      * assert (k2 == x = false) by (solve_Bounds e). rewrite H12. simpl. left.
        assumption.
      * destruct H11.  left. rewrite H11. simpl. subst. reflexivity.
Qed.

Lemma goJustLE_never_none: forall k k1 v1 m,
  goJustLE k k1 v1 m <> None.
Proof.
  intros. revert k k1 v1. induction m; intros.
  - simpl. destruct (compare k0 k) eqn : ?.
    + intro contra. discriminate contra.
    + apply IHm1.
    + apply IHm2.
  - simpl. intro contra. discriminate contra.
Qed.

(*Part 1 of the spec: If lookupLT returns a k1, v1 pair, then (k1, v1) is in the map
  and k1 is the largest key less than or equal to than k*)
Lemma lookupLE_spec_Some:
  forall (m: Map e a) lb ub k (k1: e) v1, Bounded m lb ub ->
  lookupLE k m = Some (k1, v1) ->
  sem m k1 = Some v1 /\ (_GHC.Base.<=_  k1 k = true) /\
  (forall k2, (_GHC.Base.<_  k2 k = true) /\ (k1 == k2 = false) /\
  sem m k2 <> None -> (_GHC.Base.<_  k2 k1 = true)).
Proof.
  intros. rewrite <- lookupLE_equiv in H0. generalize dependent k. revert k1 v1. induction H; intros; split; intros.
  - inversion H0.
  - inversion H0.
  - simpl in H5. simpl. destruct (compare k x) eqn : ?.
    + inversion H5; subst. assert (sem s1 k1 = None). eapply sem_outside_above. eassumption.
      solve_Bounds e. rewrite H3. rewrite Eq_Reflexive. reflexivity.
    + apply IHBounded1 in H5. destruct H5. rewrite H5. simpl. reflexivity.
    + assert ( _GHC.Base.<_ x k = true) by (order e).
      pose proof (goJustLE_finds_upper_bound k x v s2 (Some x) ub k1 v1 H0 H6 H5).
      destruct H7. specialize (H8 x).
      pose proof (goJustLE_val_in_map k x v s2 (Some x) ub k1 v1 H0 H5).
      pose proof goJustLE_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity. order e.
      assert (sem s1 k1 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H13. simpl. destruct H9.
      * assert (k1 == x = false) by (solve_Bounds e). rewrite H14. simpl. assumption.
      * destruct H9. subst. rewrite H9. reflexivity.
  - simpl in H5. destruct (compare k x ) eqn : ?.
    + inversion H5; subst. split. order e. intros. order e.
    + simpl. specialize (IHBounded1 k1 v1 k H5). destruct IHBounded1. destruct H7. split.
      assumption. intros. apply H8. destruct H9. destruct H10.
      split. assumption. split. assumption. assert (k2 == x = false) by (order e).
      assert (sem s2 k2 = None). eapply sem_outside_below. eassumption. solve_Bounds e.
      rewrite H13 in H11. rewrite H12 in H11. simpl in H11. repeat (rewrite oro_None_r in H11).
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e). split. eapply goJustLE_pres_smaller. apply H0.
      apply H6. apply H5. intros. destruct H7. destruct H8. simpl in H9.
      pose proof goJustLE_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity.
      order e. destruct (compare k2 k1) eqn : ?.
      order e.
      order e.
      assert (k2 == x = false) by (order e). rewrite H13 in H9. simpl in H9.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H14 in H9. simpl in H9. eapply goJustLE_finds_upper_bound.
       apply H0. apply H6. apply H5. split; try(assumption); split; assumption.
Qed.

Lemma goJustLE_spec_eq: forall m lb ub k v k' v',
  Bounded m lb ub ->
  sem m k = Some v ->
  (exists k1, k1 == k = true /\ goJustLE k k' v' m = Some (k1, v)).
Proof.
  intros. generalize dependent k. revert v k' v'. induction H; intros.
  - inversion H0.
  - simpl in H5. simpl. destruct (sem s1 k) eqn : ?.
    + assert (compare k x = Lt) by (solve_Bounds e).
      rewrite H6. apply IHBounded1. simpl in H5. inversion H5; subst. assumption.
    + simpl in H5. destruct (k == x) eqn : ?. assert (compare k x = Eq) by (order e).
      * rewrite H6. exists x. split. order e. inversion H5. reflexivity.
      * simpl in H5. assert (compare k x = Gt) by (solve_Bounds e). rewrite H6.
        apply IHBounded2. assumption.
Qed.

(*Part 2: If the value is in the map, lookupLE returns it*)
Lemma lookupLE_spec_eq: forall (m: Map e a) lb ub k v,
  Bounded m lb ub ->
  sem m k = Some v ->
  (exists k1, k1 == k = true /\ lookupLE k m = Some (k1, v)).
Proof.
  intros. generalize dependent k. revert v. induction H; intros.
  - inversion H0.
  - simpl in H5. rewrite <- lookupLE_equiv. simpl.
    destruct (sem s1 k) eqn : ?.
    + assert (compare k x = Lt) by (solve_Bounds e). rewrite H6. apply IHBounded1.
      simpl in H5. inversion H5; subst. assumption.
    + simpl in H5. destruct (k == x) eqn : ?.
      * simpl in H5. exists x. split. order e. assert (compare k x = Eq) by (order e).
        rewrite H6. inversion H5; subst. reflexivity.
      * simpl in H5. assert (compare k x = Gt) by (solve_Bounds e). rewrite H6.
        eapply goJustLE_spec_eq. eassumption. assumption.
Qed.

(*Part 3: If lookupLT returns None, then every key in the map is smaller than k*)
Lemma lookupLE_spec_None:
  forall (m: Map e a) lb ub k, Bounded m lb ub ->
  lookupLE k m = None ->
  (forall k2 v2, sem m k2 = Some v2 -> _GHC.Base.<_ k k2 = true).
Proof.
  intros. generalize dependent k2. generalize dependent k. revert v2. induction H; intros.
  - inversion H1.
  - rewrite <- lookupLE_equiv in H5. simpl in H5. destruct (compare k x) eqn : ?.
    + simpl in H6. order e.
    + simpl in H6. destruct (sem s1 k2) eqn : ?.
      * simpl in H6; inversion H6; subst. eapply IHBounded1. apply H5. apply Heqo.
      * simpl in H6. destruct (k2 == x) eqn : ?.
      -- order e.
      -- simpl in H6. solve_Bounds e.
    + assert (goJustLE k x v s2 <> None). apply goJustLE_never_none. rewrite H5 in H7.
      contradiction.
Qed.

End WF.


(** **** Exercise: (substi)  *)
(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors and prove that the relation you've defined coincides
    with the function given above. *)

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 :
      forall y,
        x <> y ->
        substi s x (tvar y) (tvar y)
  | s_abs1 :
      forall m T,
        substi s x (tabs x T m) (tabs x T m)
  | s_abs2 :
      forall m m' T y,
        x <> y ->
        substi s x m m' ->
        substi s x (tabs y T m) (tabs y T m')
  | s_app :
      forall t1 t2 t1' t2',
        substi s x t1 t1' ->
        substi s x t2 t2' ->
        substi s x (tapp t1 t2) (tapp t1' t2')
  | s_true :
      substi s x ttrue ttrue
  | s_false :
      substi s x tfalse tfalse
  | s_if :
      forall t1 t2 t3 t1' t2' t3',
        substi s x t1 t1' ->
        substi s x t2 t2' ->
        substi s x t3 t3' ->
        substi s x (tif t1 t2 t3) (tif t1' t2' t3').

(** **** Exercise: (step_example3)  *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  eapply multi_step. apply ST_App1. auto.
  eapply multi_step.  apply ST_AppAbs. auto.
  eapply multi_refl.
Qed.

Lemma step_example5_with_normalize :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  normalize. Qed.

(** **** Exercise: (typing_example_2_full)  *)
(** Prove the same result without using [auto], [eauto], or
    [eapply] (or [...]). *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  apply T_Abs. apply T_Abs.
  apply T_App with (T11 := TBool).
  apply T_Var. reflexivity.
  apply T_App with (T11 := TBool);
  apply T_Var; reflexivity.
Qed.

(** **** Exercise: (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
       empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
                   y (x z)
             \in T.
*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  eexists. apply T_Abs.
  apply T_Abs. apply T_Abs.
  apply T_App with (T11 := TBool).
  apply T_Var. reflexivity.
  apply T_App with (T11 := TBool); apply T_Var; reflexivity.
Qed.

(** **** Exercise: (typable_empty__closed)  *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  intros t T H. unfold closed, not. intros.
  apply free_in_context with (T := T) (Gamma := empty) in H0.
  inversion H0; subst. inversion H1. assumption.
Qed.


Require Import String.
Require Import Lists.List.
Require Import Coq.Init.Nat.
Require Import Coq.Program.Basics.

Require Export Json.
Require Export JsonTree.

Import ListNotations.
Import JsonNotations.

Local Open Scope list_scope.
Local Open Scope string_scope.
Local Open Scope json_scope.

Definition jtable := list (list (option jpoint)).

Fixpoint list_fill {X} (n: nat) (x:X): list X :=
match n with
| O => []
| S n' => x::(list_fill n' x)
end.

Definition jtable_fill (n: nat) (a: option jpoint): jtable:=
list_fill n (list_fill n None).

Definition jtable_set (jt: jtable) (m n: nat) (a: option jpoint) : jtable :=
let ml := nth_error jt m in
match ml with
| Some l => replace m jt (replace n l a)
| None => jt
end.

Inductive indjnode :=
| ind_data_node: nat -> JsonData -> indjnode
| ind_root_node: nat -> nat -> indjnode.

Definition nlj_type := (nat*(list indjnode)*jtable)%type.

Check fold_left.
(*fold_left
     : forall A B : Type,
       (A -> B -> A) ->
       list B -> A -> A*)

(*fold_right (B -> A -> A) ->
       A -> list B -> A*)

Print fold_right.

(*Lemma fst_fold_assoc: forall A1 A2 B (f:A1*A2->B->A1*A2) a l, fst (fold_left f l a) = fold_left (fun a b => fst (f a b)) l (fst a).*)

Fixpoint jtree_table' (m: nat) (k: option jpoint) (jt: jtree)
                      (nlj: nlj_type) {struct jt}: nlj_type :=
let (nl, jtb) := nlj in
let (n, jr) := nl in
match jt with
| tleaf s => let newtb := jtable_set jtb m n k in
             (S n, app jr [ind_data_node n s] , newtb)
| tlbranch tl => fold_left (fun nlj kt => jtree_table' n (Some (inr (fst kt))) (snd kt) nlj)
                            tl (S n, app jr [ind_root_node m n], jtable_set jtb m n k)
| tmbranch tm => fold_left (fun nlj kt => jtree_table' n (Some (inl (fst kt))) (snd kt) nlj)
                            tm (S n, app jr [ind_root_node m n], jtable_set jtb m n k)
end.

Definition jtree_table jt := let tb3 := jtree_table' 0 None jt (0, [],
                             (jtable_fill (length (jtree_nodes jt)) None)) in
                             (snd (fst tb3), snd tb3).

Definition clear_node_index (l: list indjnode) : jtable_row :=
map (fun n => match n with
| ind_data_node _ s => data_node s
| ind_root_node _ _ => root_node
end) l.

Lemma clear_node_index_cons: forall a l, clear_node_index (a::l) = app (clear_node_index [a]) (clear_node_index l).
Proof.
 intros. generalize dependent a. induction l; intros.
 simpl. destruct a; auto.
 simpl. destruct a; destruct a0; auto.
Qed.

Lemma clear_node_index_app: forall a l, clear_node_index (app a l) = app (clear_node_index a) (clear_node_index l).
Proof.
 intros. generalize dependent l. induction a; intros.
 simpl. auto.
 simpl. destruct a. rewrite IHa. auto.
 rewrite IHa. auto.
Qed.

Lemma one_tree_row: forall m m' n n' jtb jtb' k t jr jr' jr'',
clear_node_index (app jr jr') = clear_node_index jr'' ->
app (clear_node_index jr) (clear_node_index (snd (fst (jtree_table' m' k t (n', jr', jtb'))))) =
clear_node_index (snd (fst (jtree_table' m k t (n, jr'', jtb)))).
Proof.
 intros.  generalize dependent jr. generalize dependent jr'.
 generalize dependent jr''. generalize dependent jtb.
 generalize dependent jtb'. generalize dependent n. generalize dependent n'.
 generalize dependent m. generalize dependent m'.
 generalize dependent k.
 induction t using tree_ind'; intros.
 simpl. rewrite 2 clear_node_index_app. simpl.
 rewrite clear_node_index_app in H.
 rewrite <- H. apply app_assoc.

 simpl.
 remember (S n') as n'1. remember (app jr' [ind_root_node m' n']) as jr'1.
 remember (jtable_set jtb' m' n' k) as jtb'1.
 remember (S n) as n1. remember (app jr'' [ind_root_node m n]) as jr''1.
 remember (jtable_set jtb m n k) as jtb1.
 assert (clear_node_index (jr ++ jr'1) = clear_node_index jr''1).
 subst. rewrite 3 clear_node_index_app. simpl.
 rewrite <- H0. rewrite clear_node_index_app. apply app_assoc.
 generalize H1.
 generalize jr'1.
 generalize jr''1. generalize jtb1.
 generalize jtb'1. generalize n'1.
 generalize n1. generalize n'. generalize n.
 induction lj; intros. simpl.
 rewrite <- clear_node_index_app. auto. simpl.
 destruct a. replace (map snd ((n3, t) :: lj)) with
 (t :: map snd lj) in H; auto. inversion H. clear H.
 simpl.
 remember (jtree_table' n'0 (Some (inr n3)) t (n'2, jr'0, jtb'0)).
 remember (jtree_table' n0 (Some (inr n3)) t (n2, jr''0, jtb0)).
 destruct n4. destruct p.
 destruct n5. destruct p.
 apply IHlj with (n:=n0) (n':=n'0) (n1:=n5) (n'1:=n4) (jtb'1:=j) (jtb1:=j0)
 (jr''1:=l1) (jr'1:=l0) in H6.
 apply H6. rewrite clear_node_index_app.
 replace l0 with (snd (fst (jtree_table' n'0 (Some (inr n3)) t (n'2, jr'0, jtb'0)))).
 replace l1 with (snd (fst (jtree_table' n0 (Some (inr n3)) t (n2, jr''0, jtb0)))).
 clear IHlj. apply H5. auto. rewrite <- Heqn5. auto.
 rewrite <- Heqn4. auto.

 simpl.
 remember (S n') as n'1. remember (app jr' [ind_root_node m' n']) as jr'1.
 remember (jtable_set jtb' m' n' k) as jtb'1.
 remember (S n) as n1. remember (app jr'' [ind_root_node m n]) as jr''1.
 remember (jtable_set jtb m n k) as jtb1.
 assert (clear_node_index (jr ++ jr'1) = clear_node_index jr''1).
 subst. rewrite 3 clear_node_index_app. simpl.
 rewrite <- H0. rewrite clear_node_index_app. apply app_assoc.
 generalize H1.
 generalize jr'1.
 generalize jr''1. generalize jtb1.
 generalize jtb'1. generalize n'1.
 generalize n1. generalize n'. generalize n.
 induction mj; intros. simpl.
 rewrite <- clear_node_index_app. auto. simpl.
 destruct a. replace (map snd ((k0, t) :: mj)) with
 (t :: map snd mj) in H; auto. inversion H. clear H.
 simpl.
 remember (jtree_table' n'0 (Some (inl k0)) t (n'2, jr'0, jtb'0)).
 remember (jtree_table' n0 (Some (inl k0)) t (n2, jr''0, jtb0)).
 destruct n3. destruct p.
 destruct n4. destruct p.
 apply IHmj with (n:=n0) (n':=n'0) (n1:=n4) (n'1:=n3) (jtb'1:=j)
 (jtb1:=j0) (jr''1:=l1) (jr'1:=l0) in H6.
 apply H6. rewrite clear_node_index_app.
 replace l0 with (snd (fst (jtree_table' n'0 (Some (inl k0)) t (n'2, jr'0, jtb'0)))).
 replace l1 with (snd (fst (jtree_table' n0 (Some (inl k0)) t (n2, jr''0, jtb0)))).
 clear IHmj. apply H5. auto. rewrite <- Heqn4. auto.
 rewrite <- Heqn3. auto.
Qed.

Lemma jtable_nodes_equal': forall jt m k n jr jtb, app (clear_node_index jr) (jtree_nodes jt) =
                                     clear_node_index (snd (fst (jtree_table' m k jt (n, jr, jtb)))).
Proof.
 intros jt.
 induction jt using tree_ind'; intros.
 simpl. rewrite clear_node_index_app. simpl. auto.

 simpl.
 remember (S n) as n1.
 remember (jtable_set jtb m n k) as jtb1.
 replace (clear_node_index jr ++
 root_node :: flatten (map (compose jtree_nodes snd) lj))%list with
 ((clear_node_index (jr ++ [ind_root_node m n]) ++
  flatten (map (compose jtree_nodes snd) lj)))%list.
 remember (app jr  [ind_root_node m n]) as jr1.
 generalize n1 jr1 jtb1 n.
 induction lj; intros.
 simpl. apply app_nil_r.
 destruct a.
 replace (map snd ((n3, t) :: lj)) with (t::map snd lj) in H; auto.
 inversion_clear H. simpl.
 remember (jtree_table' n2 (Some (inr n3)) t (n0, jr0, jtb0)).
 destruct n4. destruct p.
 replace (clear_node_index jr0 ++
  compose jtree_nodes snd (n3, t) ++
    flatten (map (compose jtree_nodes snd) lj))%list with
 ((clear_node_index jr0 ++ jtree_nodes t) ++
    flatten (map (compose jtree_nodes snd) lj))%list.
 rewrite <- IHlj with (jr1:=l).
 rewrite H0 with (m:=n2) (k:=Some (inr n3)) (n:=n0) (jtb:=jtb0).
 replace l with (snd (fst (jtree_table' n2 (Some (inr n3)) t (n0, jr0, jtb0)))).
 auto. rewrite <- Heqn4. auto. auto. rewrite app_assoc.
 unfold compose. simpl. auto. rewrite clear_node_index_app.
 simpl. rewrite <- app_assoc. simpl. auto.

 simpl.
 remember (S n) as n1.
 remember (jtable_set jtb m n k) as jtb1.
 replace (clear_node_index jr ++
 root_node :: flatten (map (compose jtree_nodes snd) mj))%list with
 ((clear_node_index (jr ++ [ind_root_node m n]) ++
  flatten (map (compose jtree_nodes snd) mj)))%list.
 remember (app jr  [ind_root_node m n]) as jr1.
 generalize n1 jr1 jtb1 n.
 induction mj; intros.
 simpl. apply app_nil_r.
 destruct a.
 replace (map snd ((k0, t) :: mj)) with (t::map snd mj) in H; auto.
 inversion_clear H. simpl.
 remember (jtree_table' n2 (Some (inl k0)) t (n0, jr0, jtb0)).
 destruct n3. destruct p.
 replace (clear_node_index jr0 ++
  compose jtree_nodes snd (k0, t) ++
    flatten (map (compose jtree_nodes snd) mj))%list with
 ((clear_node_index jr0 ++ jtree_nodes t) ++
    flatten (map (compose jtree_nodes snd) mj))%list.
 rewrite <- IHmj with (jr1:=l).
 rewrite H0 with (m:=n2) (k:=Some (inl k0)) (n:=n0) (jtb:=jtb0).
 replace l with (snd (fst (jtree_table' n2 (Some (inl k0)) t (n0, jr0, jtb0)))).
 auto. rewrite <- Heqn3. auto. auto. rewrite app_assoc.
 unfold compose. simpl. auto. rewrite clear_node_index_app.
 simpl. rewrite <- app_assoc. simpl. auto.
Qed.

Lemma jtable_nodes_equal: forall jt, jtree_nodes jt =
                                     clear_node_index (fst (jtree_table jt)).
Proof.
 intros. unfold jtree_table. simpl. rewrite <- jtable_nodes_equal'.
 simpl. auto.
Qed.

Fixpoint jtable_tree' (n: nat) (m: nat)
                      (jr: jtable_row) (jtb: jtable) {struct n}: option jtree :=
match n with
| O => None
| S n' =>
let mr := nth_error jtb m in
match mr with
| Some r => let r' := indexate r in
            let fix iter_row r jt :=
            match r with
            | [] => jt
            | (_, None)::rs => iter_row rs jt
            | (n, Some (inr k))::rs =>
                                   let md := nth_error jr n in
                                   iter_row rs match md with
                                   | Some (data_node s) =>
                                               match jt with
                                               | None => Some (tlbranch [(k, tleaf s)])
                                               | Some (tlbranch tl) => Some (tlbranch (app tl [(k, tleaf s)]))
                                               | _ => jt
                                               end
                                   | Some root_node => let mt' := jtable_tree' n' n jr jtb in
                                               match mt' with
                                               | None => jt
                                               | Some t' =>
                                                 match jt with
                                                 | None => Some (tlbranch [(k, t')])
                                                 | Some (tlbranch tl) => Some (tlbranch (app tl [(k, t')]))
                                                 | _ => jt
                                                 end
                                               end
                                   | None => None
                                   end
            | (n, Some (inl k))::rs =>
                                   let md := nth_error jr n in
                                   iter_row rs match md with
                                   | Some (data_node s) =>
                                               match jt with
                                               | None => Some (tmbranch [(k, tleaf s)])
                                               | Some (tmbranch tm) => Some (tmbranch (app tm [(k, tleaf s)]))
                                               | _ => jt
                                               end
                                   | Some root_node => let mt' := jtable_tree' n' n jr jtb in
                                               match mt' with
                                               | None => jt
                                               | Some t' =>
                                                 match jt with
                                                 | None => Some (tmbranch [(k, t')])
                                                 | Some (tmbranch tm) => Some (tmbranch (app tm [(k, t')]))
                                                 | _ => jt
                                                 end
                                               end
                                   | None => None
                                   end
            end in
            let mjt' := iter_row r' None in
            match mjt' with
            | None => Some (tlbranch [])
            | _ => mjt'
            end
| None => None
end
end.

Definition jtable_tree jr jtb := jtable_tree' ((length jr)*(length jr)) 0 jr jtb.

Fixpoint path_ind' (n:nat) (lk: jpath) (jr: list indjnode) (jtb: jtable) :
                                                  option (nat + nat*nat) :=
match lk with
| [] => let mv := nth_error jr n in
        match mv with
        | None => None
        | Some (ind_data_node n _) => Some (inl n)
        | Some (ind_root_node m n) => Some (inr (m, n))
        end
| k::ks => let mr := nth_error jtb n in
           match mr with
           | None => None
           | Some r => let mn := find k r in
                       match mn with
                       | None => None
                       | Some n => path_ind' n ks jr jtb
                       end
           end
end.

Definition tree_path_ind lk jt := let (jr, tb) := jtree_table jt in
                                  path_ind' 0 lk jr tb.

Definition table_json_default jr tb j :=
let mtr := jtable_tree jr tb in
match mtr with
| None => j
| Some tr => let mj' := tree_json  tr in
                         match mj' with
                         | None => j
                         | Some j' => j'
                         end
end.

(* Haskell extraction directives *)

Require Extraction.
Extraction Language Haskell.
Extraction "coq-hs/JsonTable.hs" jtable_tree.

Eval compute in (tree_path_ind [inr 2; inl "baz"; inl "x"]
                 (json_tree ('[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}]))).

Eval compute in (tree_path_ind [inr 1; inl "bar"]
                 (json_tree ('[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}]))).

Eval compute in  (nth_error (snd (jtree_table
                 (json_tree ('[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}])))) 8).

(*tests*)

Let json1 := '[{"foo" # '[$"Andy"; $"Peter"]};
                    {"bar" # $"Good"};
                    {"baz" # {"x" # '[$"d"; $"f"]}}].
Let jtree1 := json_tree json1.
Let tn1 := jtree_nodes jtree1.
Let jtb10 := jtable_fill (length tn1) None.
Let jtb1 := jtree_table jtree1.
Eval compute in jtb1.
Let jtree1':= jtable_tree tn1 (snd jtb1).

Example jtt_eq1: Some jtree1 = jtree1'.
Proof. compute. auto. Qed.

Example jtt_eq2: tn1 = clear_node_index (fst jtb1).
Proof. auto. Qed.


Require Import Coq.Strings.String.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVar (x : string)
  | APlus (a a' : aexp).

(* MULT ORA: Inductive claexp : Type :=
   | ANum (n : nat)
   | APlus (a a' : aexp).
Fixpoint embed : claexp -> aexp *)

Fixpoint closed (e : aexp) : bool :=
  match e with
  | ANum n => true
  | AVar x => false
  | APlus a a' => closed a && closed a'
  end.

Example ex1 : closed (APlus (ANum 3) (ANum 4)) = true. reflexivity. Qed.

Example ex2 : closed (APlus (ANum 3) (AVar "x")) = false. reflexivity. Qed.

Definition state : Type := string -> nat.

Fixpoint aeval (e : aexp)(s : state) : nat := match e with
  | ANum n => n
  | AVar x => s x
  | APlus a a' => aeval a s + aeval a' s
  end.

Definition F (b : bool) : Type :=
  if b then True else False.

Definition hamisbol (p : true = false) : False.
assert (F false). rewrite <- p. simpl. trivial.
simpl in X. exact X. Qed.

Require Import Coq.Bool.Bool.

Theorem closedEval (e : aexp)(s s' : state)(p : closed e = true) :
  aeval e s = aeval e s'.
induction e. simpl. reflexivity. simpl in p.
exfalso. apply hamisbol. symmetry. exact p.
simpl. simpl in p.
Check andb_true_iff.
apply andb_true_iff in p. destruct p as [H1 H2].
rewrite -> IHe1. rewrite -> IHe2. reflexivity.
exact H2. exact H1. Qed.

Inductive zart : aexp -> Prop :=
  | szam (n : nat) : zart (ANum n)
  | osszeg (a a' : aexp)(az : zart a)
           (a'z : zart a') : zart (APlus a a').

Example pl1 : zart (APlus (ANum 3) (ANum 4)).
apply osszeg. apply szam. apply szam. Qed.

Example pl3 : zart (APlus (ANum 3)
                          (APlus (ANum 1) (ANum 2))).
apply osszeg. apply szam. apply osszeg; apply szam.
Qed.
(*exact (osszeg _ _ (szam _) (osszeg _ _ (szam _) (szam _))).*)

(*
Theorem zartEval (e : aexp)(s s' : state)(p : zart e) :
  aeval e s = aeval e s'.
*)

Inductive fstep : aexp -> state -> nat -> Prop :=
  | snum (n : nat)(s : state) : fstep (ANum n) s n
  | svar (x : string)(s : state) : fstep (AVar x) s (s x)
  | splus (n i : nat)(a2 : aexp)(s : state) :
          fstep a2 s i ->
          fstep (APlus (ANum n) a2) s (n + i).

Notation "< a , s >=> i" := (fstep a s i) (at level 50).

Definition empty : state := fun _ => 0.

Example ex3 : < APlus (ANum 3) (ANum 4) , empty >=> 7.
apply (splus 3 4). apply snum. Qed.

Inductive step : aexp -> state -> aexp -> state -> Prop :=
  | splus2 (a1 a2 a1' : aexp)(s : state) :
           step a1 s a1' s ->
           step (APlus a1 a2) s (APlus a1' a2) s.
(* TODO: tobbi eset *)

Notation "< a , s >=>< a' , s' >" := (step2 a s a' s') (at level 50).


Require Export HoTT Ch07.

Lemma equiv_functor_Trunc (n : trunc_index) (A B : Type)
  : (A <~> B) -> (Trunc n A) <~> (Trunc n B).
Proof.
  intro e.
  simple refine (equiv_adjointify _ _ _ _).
  apply Trunc_rec. intro a. apply (tr (e a)).
  apply Trunc_rec. intro b. apply (tr (e^-1 b)).
  refine (Trunc_ind _ _).
  intro b. simpl. apply (ap tr). apply eisretr.
  refine (Trunc_ind _ _).
  intro a. simpl. apply (ap tr). apply eissect.
Defined.


Require Import List Lia FunctionalExtensionality.
Import ListNotations.
From Minirust.def Require Import encoding utils le ty.
From Minirust.proof.lemma Require Import utils subslice.

Section chunks.

Context {memory: Memory}.

Lemma chunks_step {s c T} {l: list T}: chunks (S c) s l = (firstn s l)::(chunks c s (skipn s l)).
Proof.
unfold chunks.
simpl.
rewrite subslice_zero.
f_equal.
unfold subslice_with_length.
rewrite <- seq_shift.
rewrite map_map.
f_equal.
apply functional_extensionality_dep.
intros x.
f_equal.
rewrite skipn_add.
f_equal.
lia.
Qed.

Lemma concat_len {T n k} {ll: list (list T)}
  (Hl1: length ll = k)
  (Hl2: Forall (fun x => length x = n) ll) :
  length (concat ll) = n * k.
Proof.
generalize dependent ll.
generalize dependent n.
induction k as [|k]. {
  intros.
  rewrite ((proj1 (length_zero_iff_nil ll)) Hl1).
  simpl.
  lia.
}

intros n ll Hlen Hlen_inner.

destruct ll.
{ inversion Hlen. }

assert (length ll = k).
{  inversion Hlen. auto. }

assert (length l = n).
{ inversion Hlen_inner. auto. }

assert (length (concat ll) = n * k). {
  apply IHk. { assumption. }

  inversion Hlen_inner.
  auto.
}

simpl.
rewrite app_length.
lia.
Qed.

Lemma chunks_len1 {T c s} {l: list T} (H: length l = c * s) :
  length (chunks c s l) = c.
Proof.
generalize dependent l.
induction c.
{ intros l H. simpl. auto. }

intros l H.
simpl.
f_equal.
rewrite map_length.
apply seq_length.
Qed.

Lemma chunks_len2 {T c s} {l: list T} (H: length l = c * s) :
  Forall (fun x => length x = s) (chunks c s l).
Proof.
generalize dependent l.
induction c as [|c IH].
{ intros l H. apply Forall_nil. }

intros l H.
rewrite chunks_step.
apply Forall_cons.
{ rewrite firstn_length. lia. }

apply IH.
rewrite skipn_length.
lia.
Qed.

Lemma chunks_len {T c s} {l: list T} (H: length l = c * s) :
  length (chunks c s l) = c /\ Forall (fun x => length x = s) (chunks c s l).
Proof. split; [> apply (chunks_len1 H) | apply (chunks_len2 H)]. Qed.

Lemma chunks_concat {T c s} {l : list (list T)} (H1: length l = c) (H: Forall (fun x => length x = s) l) :
  chunks c s (concat l) = l.
Proof.
rewrite <- H1. clear c H1.
induction l as [|x l IH].
{ simpl. unfold chunks. simpl. auto. }

simpl.
rewrite chunks_step.
assert (length x = s).
{ inversion H. auto. }

f_equal. {
  rewrite firstn_app.
  replace (s - length x) with 0; try lia.
  simpl.
  rewrite app_nil_r.
  rewrite <- H0.
  apply firstn_all.
}

assert (Forall (fun x => length x = s) l).
{ inversion H. auto. }

rewrite skipn_app.
replace (s - length x) with 0; try lia.
simpl.
rewrite <- H0.
rewrite skipn_all.
simpl.
rewrite H0.
apply (IH H1).
Qed.

Lemma concat_chunks [T c s] [l: list T] (H: length l = c * s): concat (chunks c s l) = l.
Proof.
generalize dependent l.
induction c as [|c IH].
{ intros. simpl. destruct l; auto. simpl in H. discriminate H. }

intros.
rewrite chunks_step.
simpl.
rewrite IH. { apply firstn_skipn. }
rewrite skipn_length.
lia.
Qed.

Lemma cons_le [T] [x1 x2: T] [l1 l2 : list T] [_: DefinedRelation T]
  (Hlex: le x1 x2)
  (Hlel : le l1 l2) :
  le (x1::l1) (x2::l2).
Proof.
unfold le. unfold list_DefinedRelation. unfold le_list.
split; auto.
Qed.

Lemma cons_le_rev [x1 x2 : AbstractByte] [l1 l2 : list AbstractByte] (Hle: le (x1::l1) (x2::l2)) :
  (le x1 x2) /\ (le l1 l2).
Proof.
split; inversion Hle; auto.
Qed.

Lemma app_le [l1 l2 l1' l2' : list AbstractByte]
  (Hle: le l1 l2)
  (Hle': le l1' l2'):
  le (l1 ++ l1') (l2 ++ l2').
Proof.
generalize dependent l2.
generalize dependent l2'.
generalize dependent l1'.
induction l1 as [|x1 l1 IH]. {
  intros.
  simpl in Hle.
  simpl ([] ++ _).
  destruct l2. { auto. }
  contradiction Hle.
}

intros.
destruct l2 as [|x2 l2].
{ simpl in Hle. contradiction Hle. }

do 2 rewrite <- app_comm_cons.
destruct (cons_le_rev Hle).
apply cons_le. { auto. }
apply IH; auto.
Qed.

Lemma concat_le [l1 l2: list (list AbstractByte)]
  (Hl: length l1 = length l2)
  (H: Forall (fun x => le (fst x) (snd x)) (combine l1 l2)) :
 le (concat l1) (concat l2).
Proof.
generalize dependent l2.
induction l1 as [|x1 l1 IH].
{ intros. simpl. destruct l2; simpl; auto. discriminate Hl. }

intros.
destruct l2 as [|x2 l2].
{ discriminate Hl. }

simpl (concat _).
apply app_le. {
  simpl (combine _ _) in H.
  inversion H.
  simpl in H2.
  auto.
}

apply IH.
{ simpl in Hl. inversion Hl. auto. }

inversion H.
auto.
Qed.

Lemma firstn_le n [T] [l1 l2: list T] {_: DefinedRelation T} (Hle: le l1 l2) :
  le (firstn n l1) (firstn n l2).
Proof.
generalize dependent l2.
generalize dependent n.
induction l1 as [|x1 l1 IH]. {
  intros.
  rewrite firstn_nil.
  destruct l2.
  - rewrite firstn_nil. auto.
  - contradict Hle.
}

intros.
destruct l2.
{ contradict Hle. }

destruct n.
{ simpl. auto. }

simpl (firstn _ _).
apply cons_le.
- inversion Hle. auto.
- apply IH.
  inversion Hle.
  auto.
Qed.

Lemma skipn_le n [T] [l1 l2: list T] {_: DefinedRelation T} (Hle: le l1 l2) :
  le (skipn n l1) (skipn n l2).
Proof.
generalize dependent l2.
generalize dependent n.
induction l1 as [|x1 l1 IH]. {
  intros.
  destruct l2.
  - rewrite skipn_nil. auto.
  - contradict Hle.
}

intros.
destruct l2.
{ contradict Hle. }

destruct n.
{ simpl (skipn 0 _). auto. }

simpl skipn.
inversion Hle.
auto.
Qed.

Lemma chunks_le [c s] [l1 l2: list AbstractByte]
  (Hle: le l1 l2)
  (Hlen1 : length l1 = c * s)
  (Hlen2 : length l2 = c * s):
 le (chunks c s l1) (chunks c s l2).
Proof.
generalize dependent l1.
generalize dependent l2.
induction c as [|c IH].
{ intros. simpl in Hlen1. destruct l1; try discriminate Hlen1. simpl. auto. }

intros.
do 2 rewrite chunks_step.
apply cons_le. { apply firstn_le. auto. }
apply IH.
- rewrite skipn_length. lia.
- apply skipn_le. auto.
- rewrite skipn_length. lia.
Qed.

End chunks.


Require Export FcEtt.ett_inf.
Require Import FcEtt.imports.

(**** Facts about finite sets ****)

Lemma union_notin_iff a s1 s2 :
  a `notin` union s1 s2 ↔ a `notin` s1 ∧ a `notin` s2.
Proof. fsetdec. Qed.

Lemma dom_app_mid {C} (E F G : list (atom * C)) :
  dom (E ++ F ++ G) [=] union (dom F) (dom (E ++ G)).
Proof. repeat rewrite dom_app; fsetdec. Qed.
Hint Resolve dom_app_mid.

Lemma dom_app_mid' {C} (E F G : list (atom * C)) :
  union (dom F) (dom (E ++ G)) [=] dom (E ++ F ++ G).
Proof. by symmetry. Qed.
Hint Resolve dom_app_mid'.

Lemma singleton_add_subset (a : atom) (s : atoms) :
  singleton a [<=] add a s.
Proof. fsetdec. Qed.

Lemma union_subset (s1 s2 t : atoms) :
  union s1 s2 [<=] t <-> s1 [<=] t /\ s2 [<=] t.
Proof. split; [split | case]; fsetdec. Qed.

Lemma add_notin (s1 s2 : atoms) (a : atom) :
  s1 [<=] add a s2 ->
  a `notin` s1 ->
  s1 [<=] s2.
Proof. fsetdec. Qed.

Lemma in_dom_app {A} (a : atom) (G1 G2 : list (atom * A)) :
  a `in` dom (G1 ++ G2) ↔ a `in` dom G1 ∨ a `in` dom G2.
Proof. rewrite dom_app; fsetdec. Qed.

Lemma notin_dom_app {A} (a : atom) (G1 G2 : list (atom * A)) :
  a `notin` dom (G1 ++ G2) ↔ a `notin` dom G1 ∧ a `notin` dom G2.
Proof. rewrite dom_app; fsetdec. Qed.

Lemma not_uniq_app1_app1 {A} (a : atom) (v1 v2 : A) (G1 G2 : list (atom * A)) :
  ¬ uniq ((a ~ v1) ++ G1 ++ (a ~ v2) ++ G2).
Proof. rewrite uniq_app_iff disjoint_one_l notin_dom_app /=; fsetdec. Qed.

Lemma not_uniq_cons_cons {A} (a : atom) (v1 v2 : A) (G1 G2 : list (atom * A)) :
  ¬ uniq ((a,v1) :: G1 ++ (a,v2) :: G2).
Proof. rewrite uniq_cons_iff notin_dom_app /=; fsetdec. Qed.

Lemma notin_remove :
  forall x y S, x `notin` S -> x `notin` remove y S.
Proof.
  intros.
  fsetdec.
Qed.

Lemma subset_notin : forall x S1 S2,
    x `notin` S2 -> S1 [<=] S2 -> x `notin` S1.
Proof.
  fsetdec.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_NCorder.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_extension.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_lessthancongruence.
Require Import ProofCheckingEuclid.lemma_onray_strict.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_ABD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ABD.
Require Import ProofCheckingEuclid.lemma_s_lt.
Require Import ProofCheckingEuclid.lemma_s_n_col_ncol.
Require Import ProofCheckingEuclid.lemma_s_ncol_ABD_col_ABC_ncol_ACD.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.
Require Import ProofCheckingEuclid.lemma_s_onray.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_crossbar :
	forall A B C E U V,
	Triangle A B C ->
	BetS A E C ->
	OnRay B A U ->
	OnRay B C V ->
	exists X, OnRay B E X /\ BetS U X V.
Proof.
	intros A B C E U V.
	intros Triangle_ABC.
	intros BetS_A_E_C.
	intros OnRay_BA_U.
	intros OnRay_BC_V.

	assert (nCol A B C) as nCol_A_B_C by (unfold Triangle in Triangle_ABC; exact Triangle_ABC).
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_C) as n_Col_A_B_C.
	pose proof (lemma_NCorder _ _ _ nCol_A_B_C) as (_ & nCol_B_C_A & _ & _ & _).

	destruct nCol_A_B_C as (neq_A_B & _ & neq_B_C & nBetS_A_B_C & _ & _).
	pose proof (lemma_inequalitysymmetric _ _ neq_A_B) as neq_B_A.

	pose proof (lemma_onray_strict _ _ _ OnRay_BA_U) as neq_B_U.
	pose proof (lemma_onray_strict _ _ _ OnRay_BC_V) as neq_B_V.
	destruct OnRay_BA_U as (J & BetS_J_B_U & BetS_J_B_A).
	destruct OnRay_BC_V as (K & BetS_K_B_V & BetS_K_B_C).

	pose proof (lemma_inequalitysymmetric _ _ neq_B_U) as neq_U_B.

	pose proof (lemma_extension _ _ _ _ neq_B_A neq_B_U) as (P & BetS_B_A_P & Cong_AP_BU).
	pose proof (lemma_extension _ _ _ _ neq_B_C neq_B_V) as (Q & BetS_B_C_Q & Cong_CQ_BV).

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AP_BU) as Cong_BU_AP.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_CQ_BV) as Cong_BV_CQ.

	assert (Col B A P) as Col_B_A_P by (unfold Col; one_of_disjunct BetS_B_A_P).
	assert (Col B C Q) as Col_B_C_Q by (unfold Col; one_of_disjunct BetS_B_C_Q).
	pose proof (lemma_collinearorder _ _ _ Col_B_A_P) as (_ & _ & Col_P_B_A & _ & _).
	pose proof (lemma_collinearorder _ _ _ Col_B_C_Q) as (_ & _ & Col_Q_B_C & _ & _).
	pose proof (lemma_betweennotequal _ _ _ BetS_B_A_P) as (_ & _ & neq_B_P).
	pose proof (lemma_betweennotequal _ _ _ BetS_B_C_Q) as (_ & _ & neq_B_Q).
	pose proof (lemma_inequalitysymmetric _ _ neq_B_P) as neq_P_B.
	pose proof (lemma_inequalitysymmetric _ _ neq_B_Q) as neq_Q_B.

	pose proof (axiom_betweennesssymmetry _ _ _ BetS_B_A_P) as BetS_P_A_B.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_B_C_Q) as BetS_Q_C_B.
	pose proof (lemma_orderofpoints_ABC_BCD_ABD _ _ _ _ BetS_J_B_A BetS_B_A_P) as BetS_J_B_P.
	pose proof (lemma_orderofpoints_ABC_BCD_ABD _ _ _ _ BetS_K_B_C BetS_B_C_Q) as BetS_K_B_Q.

	assert (~ eq B E) as neq_B_E.
	{
		intros eq_B_E.

		assert (BetS A B C) as BetS_A_B_C by (rewrite eq_B_E; exact BetS_A_E_C).

		contradict BetS_A_B_C.
		exact nBetS_A_B_C.
	}
	pose proof (lemma_inequalitysymmetric _ _ neq_B_E) as neq_E_B.
	pose proof (postulate_Euclid2 _ _ neq_E_B) as (N & BetS_E_B_N).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_B_N) as BetS_N_B_E.

	pose proof (lemma_s_ncol_ABD_col_ABC_ncol_ACD _ _ _ _ nCol_B_C_A Col_B_C_Q neq_B_Q) as nCol_B_Q_A.
	pose proof (lemma_NCorder _ _ _ nCol_B_Q_A) as (_ & _ & _ & nCol_B_A_Q & _).

	pose proof (lemma_s_ncol_ABD_col_ABC_ncol_ACD _ _ _ _ nCol_B_A_Q Col_B_A_P neq_B_P) as nCol_B_P_Q.
	pose proof (lemma_NCorder _ _ _ nCol_B_P_Q) as (_ & _ & _ & _ & nCol_Q_P_B).

	pose proof (postulate_Pasch_outer _ _ _ _ _ BetS_A_E_C BetS_B_C_Q nCol_B_Q_A) as (F & BetS_A_F_Q & BetS_B_E_F).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_A_F_Q) as BetS_Q_F_A.

	pose proof (postulate_Pasch_outer Q B A F P BetS_Q_F_A BetS_B_A_P nCol_B_P_Q) as (W & BetS_Q_W_P & BetS_B_F_W).
	pose proof (lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_B_E_F BetS_B_F_W) as BetS_B_E_W.

	pose proof (cn_congruencereverse A P) as Cong_AP_PA.
	pose proof (cn_congruencereverse P B) as Cong_PB_BP.
	pose proof (cn_congruencereverse C Q) as Cong_CQ_QC.
	pose proof (cn_congruencereverse Q B) as Cong_QB_BQ.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_BU_AP Cong_AP_PA) as Cong_BU_PA.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_BV_CQ Cong_CQ_QC) as Cong_BV_QC.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BU_PA) as Cong_PA_BU.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BV_QC) as Cong_QC_BV.
	pose proof (lemma_s_lt _ _ _ _ _ BetS_P_A_B Cong_PA_BU) as Lt_BU_PB.
	pose proof (lemma_s_lt _ _ _ _ _ BetS_Q_C_B Cong_QC_BV) as Lt_BV_QB.
	pose proof (lemma_lessthancongruence _ _ _ _ _ _ Lt_BU_PB Cong_PB_BP) as Lt_BU_BP.
	pose proof (lemma_lessthancongruence _ _ _ _ _ _ Lt_BV_QB Cong_QB_BQ) as Lt_BV_BQ.
	destruct Lt_BU_BP as (S & BetS_B_S_P & Cong_BS_BU).
	destruct Lt_BV_BQ as (R & BetS_B_R_Q & Cong_BR_BV).
	pose proof (axiom_orderofpoints_ABD_BCD_ABC _ _ _ _ BetS_J_B_P BetS_B_S_P) as BetS_J_B_S.
	pose proof (axiom_orderofpoints_ABD_BCD_ABC _ _ _ _ BetS_K_B_Q BetS_B_R_Q) as BetS_K_B_R.
	pose proof (lemma_extensionunique _ _ _ _ BetS_J_B_S BetS_J_B_U Cong_BS_BU) as eq_S_U.
	pose proof (lemma_extensionunique _ _ _ _ BetS_K_B_R BetS_K_B_V Cong_BR_BV) as eq_R_V.
	assert (BetS B U P) as BetS_B_U_P by (rewrite <- eq_S_U; exact BetS_B_S_P).
	assert (BetS B V Q) as BetS_B_V_Q by (rewrite <- eq_R_V; exact BetS_B_R_Q).

	pose proof (postulate_Pasch_inner _ _ _ _ _ BetS_Q_W_P BetS_B_U_P nCol_Q_P_B) as (M & BetS_Q_M_U & BetS_B_M_W).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_Q_M_U) as BetS_U_M_Q.

	assert (Col B U P) as Col_B_U_P by (unfold Col; one_of_disjunct BetS_B_U_P).
	pose proof (lemma_collinearorder _ _ _ Col_B_U_P) as (_ & _ & _ & Col_B_P_U & _).
	pose proof (lemma_s_ncol_ABD_col_ABC_ncol_ACD _ _ _ _ nCol_B_P_Q Col_B_P_U neq_B_U) as nCol_B_U_Q.
	pose proof (lemma_NCorder _ _ _ nCol_B_U_Q) as (_ & nCol_U_Q_B & _ & _ & _).

	pose proof (postulate_Pasch_inner _ _ _ _ _ BetS_U_M_Q BetS_B_V_Q nCol_U_Q_B) as (H & BetS_U_H_V & BetS_B_H_M).

	pose proof (lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_B_H_M BetS_B_M_W) as BetS_B_H_W.
	pose proof (lemma_orderofpoints_ABC_BCD_ABD _ _ _ _ BetS_N_B_E BetS_B_E_W) as BetS_N_B_W.
	pose proof (axiom_orderofpoints_ABD_BCD_ABC _ _ _ _ BetS_N_B_W BetS_B_H_W) as BetS_N_B_H.

	pose proof (lemma_s_onray _ _ _ _ BetS_N_B_E BetS_N_B_H) as OnRay_BE_H.

	exists H.
	split.
	exact OnRay_BE_H.
	exact BetS_U_H_V.
Qed.

End Euclid.


Require Export XR_Rminus.
Require Export XR_Rplus_assoc.
Require Export XR_Rplus_comm.
Require Export XR_Rplus_opp_r.
Require Export XR_Rplus_0_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2.
Proof.
  intros x y.
  unfold Rminus.
  rewrite (Rplus_comm y).
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Lemma lem: forall m n, plus (Succ m) n = plus m (Succ n).
Proof.
intros. simpl. induction m.
  - simpl. rewrite IHm. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (half (plus x x)) x.
Proof.
induction x.
  - simpl. destruct x.
    * simpl. lfind.  rewrite IHx.  reflexivity.
Admitted.


Section ml.
Theorem OrdistP: forall (A:Prop)(B:Set -> Prop),
A \/ (forall x:Set, B x) -> forall x:Set, (A \/ (B x)).
Proof.
intros a f.
intro h0.
intro b.
elim h0.
intro ha; left; assumption.
intro h1.
right.
apply h1.
Qed.
End ml.

Check OrdistP.


Require Import List Lia.
Import ListNotations.
Require Import ssreflect ssrbool ssrfun.

Require Import Undecidability.HilbertCalculi.HSC.

Set Default Goal Selector "!".

(* number of nodes in the syntax tree of a formula *)
Fixpoint size s :=
  match s with
  | var _ => 1
  | arr s t => S (size s + size t)
  end.

(* list of first k arguments *)
Fixpoint arguments (k: nat) (t: formula) :=
  match k with
  | 0 => []
  | S k =>
    match t with
    | var _ => []
    | arr s t => s :: (arguments k t)
    end
  end.

(* target after first k arguments *)
Fixpoint target (k: nat) (t: formula) :=
  match k with
  | 0 => t
  | S k =>
    match t with
    | var _ => t
    | arr _ t => target k t
    end
  end.

(* Hilbert-style calculus with derivation depth *)
Inductive der (Gamma: list formula) : nat -> formula -> Prop :=
  | der_var {ζ: nat -> formula} {s t: formula} {k n: nat} :
      In s Gamma ->
      Forall (der Gamma n) (arguments k (substitute ζ s)) ->
      target k (substitute ζ s) = t ->
      der Gamma (S n) t.

(* can be replaced by derE *)
Lemma der_0E {n Gamma t} : der Gamma n t -> n = S (Nat.pred n).
Proof. move=> H. by inversion H. Qed.

Lemma derE {n Gamma t} : der Gamma n t ->
  exists (ζ: nat -> formula) (s: formula) (k: nat),
    n = S (Nat.pred n) /\
    In s Gamma /\
    Forall (der Gamma (Nat.pred n)) (arguments k (substitute ζ s)) /\
    target k (substitute ζ s) = t.
Proof. move=> H. inversion H. do 3 eexists. by eauto. Qed.

Lemma der_mon {n m t Gamma} : der Gamma n t -> n <= m -> der Gamma m t.
Proof.
  elim: n m Gamma t; first by move=> > /der_0E.
  move=> n IH m Gamma t.
  move /derE => [ζ [s' [k']]].
  move=> [_ [? [? ?]]] ?.
  have -> : m = S (Nat.pred m) by lia.
  apply: der_var; try eassumption.
  apply: Forall_impl; last by eassumption.
  move=> ? /IH. apply. by lia.
Qed.

Lemma target_S {r s t k} : target k r = arr s t -> target (S k) r = t.
Proof.
  elim: k r s t; first by move=> > /= ->.
  by move=> k IH [> /= |  > /= /IH <-].
Qed.

Lemma arguments_S {r s t k} : target k r = arr s t -> arguments (S k) r = (arguments k r) ++ [s].
Proof.
  elim: k r s t; first by move=> > /= ->.
  by move=> k IH [> /= |  > /= /IH <-].
Qed.

(* every hsc derivation has a depth *)
Lemma hsc_der {Gamma t} : hsc Gamma t -> exists n, der Gamma n t.
Proof.
  elim.
  - move=> ζ s /der_var => /(_ ζ (substitute ζ s) 0 0).
    move /(_ ltac:(by constructor)). move /(_ ltac:(done)).
    move=> ?. by exists 1.
  - move=> s' t' _ [n1 /derE +] _ [n2 /derE].
    move=> [ζ1 [s1 [k1 [-> [Hs1 [? Hk1]]]]]].
    move=> [ζ2 [s2 [k2 [-> [? [? ?]]]]]].
    exists (S (S (n1+n2))). apply: (der_var _ (ζ := ζ1) (s := s1) (k := S k1)).
      + done.
      + rewrite (arguments_S ltac:(eassumption)). apply /Forall_app. constructor.
        * apply: Forall_impl; last eassumption.
          move=> ? /der_mon. apply. by lia.
        * constructor; last done.
          apply: der_var; last eassumption; first done.
          apply: Forall_impl; last eassumption.
          move=> ? /der_mon. apply. by lia.
      + apply: target_S. by eassumption.
Qed.

(* every compound derivation can be decomposed *)
Lemma der_hsc {Gamma t n} : der Gamma n t -> hsc Gamma t.
Proof.
  elim: n Gamma t; first by move=> > /der_0E.
  move=> n IH Gamma t /derE.
  move=> [ζ [s [k [-> [? [+ +]]]]]].
  have : hsc Gamma (substitute ζ s) by apply: hsc_var.
  move: IH. clear. move: (substitute ζ s) => {}s. clear.
  move=> IH. elim: k s.
  { move=> s /= *. by subst t. }
  move=> k IHk. case.
  { move=> ? /= *. by subst t. }
  move=> s1 s2 /= /hsc_arr + /Forall_cons_iff [/IH H].
  by move=> /(_ H){H} /IHk.
Qed.