(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Functions for computing the number of digits of integers and related theorems. *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.
Require Import Fcore_digits.

Section Fcalc_digits.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Theorem Zdigits_ln_beta :
  forall n,
  n <> Z0 ->
  Zdigits beta n = ln_beta beta (Z2R n).
Proof.
intros n Hn.
destruct (ln_beta beta (Z2R n)) as (e, He) ; simpl.
specialize (He (Z2R_neq _ _ Hn)).
rewrite <- Z2R_abs in He.
assert (Hd := Zdigits_correct beta n).
assert (Hd' := Zdigits_gt_0 beta n).
apply Zle_antisym ; apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
rewrite <- Z2R_Zpower by omega.
now apply Z2R_le.
apply Rle_lt_trans with (1 := proj1 He).
rewrite <- Z2R_Zpower by omega.
now apply Z2R_lt.
Qed.

Theorem ln_beta_F2R_Zdigits :
  forall m e, m <> Z0 ->
  (ln_beta beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z.
Proof.
intros m e Hm.
rewrite ln_beta_F2R with (1 := Hm).
apply (f_equal (fun v => Zplus v e)).
apply sym_eq.
now apply Zdigits_ln_beta.
Qed.

Theorem Zdigits_mult_Zpower :
  forall m e,
  m <> Z0 -> (0 <= e)%Z ->
  Zdigits beta (m * Zpower beta e) = (Zdigits beta m + e)%Z.
Proof.
intros m e Hm He.
rewrite <- ln_beta_F2R_Zdigits with (1 := Hm).
rewrite Zdigits_ln_beta.
rewrite Z2R_mult.
now rewrite Z2R_Zpower with (1 := He).
contradict Hm.
apply Zmult_integral_l with (2 := Hm).
apply neq_Z2R.
rewrite Z2R_Zpower with (1 := He).
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem Zdigits_Zpower :
  forall e,
  (0 <= e)%Z ->
  Zdigits beta (Zpower beta e) = (e + 1)%Z.
Proof.
intros e He.
rewrite <- (Zmult_1_l (Zpower beta e)).
rewrite Zdigits_mult_Zpower ; try easy.
apply Zplus_comm.
Qed.

Theorem Zdigits_le :
  forall x y,
  (0 <= x)%Z -> (x <= y)%Z ->
  (Zdigits beta x <= Zdigits beta y)%Z.
Proof.
intros x y Hx Hxy.
case (Z_lt_le_dec 0 x).
clear Hx. intros Hx.
rewrite 2!Zdigits_ln_beta.
apply ln_beta_le.
now apply (Z2R_lt 0).
now apply Z2R_le.
apply Zgt_not_eq.
now apply Zlt_le_trans with x.
now apply Zgt_not_eq.
intros Hx'.
rewrite (Zle_antisym _ _ Hx' Hx).
apply Zdigits_ge_0.
Qed.

Theorem lt_Zdigits :
  forall x y,
  (0 <= y)%Z ->
  (Zdigits beta x < Zdigits beta y)%Z ->
  (x < y)%Z.
Proof.
intros x y Hy.
cut (y <= x -> Zdigits beta y <= Zdigits beta x)%Z. omega.
now apply Zdigits_le.
Qed.

Theorem Zpower_le_Zdigits :
  forall e x,
  (e < Zdigits beta x)%Z ->
  (Zpower beta e <= Zabs x)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct beta x) as (H1,H2).
apply Zle_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.

Theorem Zdigits_le_Zpower :
  forall e x,
  (Zabs x < Zpower beta e)%Z ->
  (Zdigits beta x <= e)%Z.
Proof.
intros e x.
generalize (Zpower_le_Zdigits e x).
omega.
Qed.

Theorem Zpower_gt_Zdigits :
  forall e x,
  (Zdigits beta x <= e)%Z ->
  (Zabs x < Zpower beta e)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct beta x) as (H1,H2).
apply Zlt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.

Theorem Zdigits_gt_Zpower :
  forall e x,
  (Zpower beta e <= Zabs x)%Z ->
  (e < Zdigits beta x)%Z.
Proof.
intros e x Hex.
generalize (Zpower_gt_Zdigits e x).
omega.
Qed.

(** Characterizes the number digits of a product.

This strong version is needed for proofs of division and square root
algorithms, since they involve operation remainders.
*)

Theorem Zdigits_mult_strong :
  forall x y,
  (0 <= x)%Z -> (0 <= y)%Z ->
  (Zdigits beta (x + y + x * y) <= Zdigits beta x + Zdigits beta y)%Z.
Proof.
intros x y Hx Hy.
case (Z_lt_le_dec 0 x).
clear Hx. intros Hx.
case (Z_lt_le_dec 0 y).
clear Hy. intros Hy.
(* . *)
assert (Hxy: (0 < Z2R (x + y + x * y))%R).
apply (Z2R_lt 0).
change Z0 with (0 + 0 + 0)%Z.
apply Zplus_lt_compat.
now apply Zplus_lt_compat.
now apply Zmult_lt_0_compat.
rewrite 3!Zdigits_ln_beta ; try now (apply sym_not_eq ; apply Zlt_not_eq).
apply ln_beta_le_bpow with (1 := Rgt_not_eq _ _ Hxy).
rewrite Rabs_pos_eq with (1 := Rlt_le _ _ Hxy).
destruct (ln_beta beta (Z2R x)) as (ex, Hex). simpl.
specialize (Hex (Rgt_not_eq _ _ (Z2R_lt _ _ Hx))).
destruct (ln_beta beta (Z2R y)) as (ey, Hey). simpl.
specialize (Hey (Rgt_not_eq _ _ (Z2R_lt _ _ Hy))).
apply Rlt_le_trans with (Z2R (x + 1) * Z2R (y + 1))%R.
rewrite <- Z2R_mult.
apply Z2R_lt.
apply Zplus_lt_reg_r with (- (x + y + x * y + 1))%Z.
now ring_simplify.
rewrite bpow_plus.
apply Rmult_le_compat ; try (apply (Z2R_le 0) ; omega).
rewrite <- (Rmult_1_r (Z2R (x + 1))).
change (F2R (Float beta (x + 1) 0) <= bpow ex)%R.
apply F2R_p1_le_bpow.
exact Hx.
unfold F2R. rewrite Rmult_1_r.
apply Rle_lt_trans with (Rabs (Z2R x)).
apply RRle_abs.
apply Hex.
rewrite <- (Rmult_1_r (Z2R (y + 1))).
change (F2R (Float beta (y + 1) 0) <= bpow ey)%R.
apply F2R_p1_le_bpow.
exact Hy.
unfold F2R. rewrite Rmult_1_r.
apply Rle_lt_trans with (Rabs (Z2R y)).
apply RRle_abs.
apply Hey.
apply neq_Z2R.
now apply Rgt_not_eq.
(* . *)
intros Hy'.
rewrite (Zle_antisym _ _ Hy' Hy).
rewrite Zmult_0_r, 3!Zplus_0_r.
apply Zle_refl.
intros Hx'.
rewrite (Zle_antisym _ _ Hx' Hx).
rewrite Zmult_0_l, Zplus_0_r, 2!Zplus_0_l.
apply Zle_refl.
Qed.

Theorem Zdigits_mult :
  forall x y,
  (Zdigits beta (x * y) <= Zdigits beta x + Zdigits beta y)%Z.
Proof.
intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs _ x).
rewrite <- (Zdigits_abs _ y).
apply Zle_trans with (Zdigits beta (Zabs x + Zabs y + Zabs x * Zabs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
generalize (Zabs_pos x) (Zabs_pos y).
omega.
apply Zdigits_mult_strong ; apply Zabs_pos.
Qed.

Theorem Zdigits_mult_ge :
  forall x y,
  (x <> 0)%Z -> (y <> 0)%Z ->
  (Zdigits beta x + Zdigits beta y - 1 <= Zdigits beta (x * y))%Z.
Proof.
intros x y Zx Zy.
cut ((Zdigits beta x - 1) + (Zdigits beta y - 1) < Zdigits beta (x * y))%Z. omega.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult.
rewrite Zpower_exp.
apply Zmult_le_compat.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_ge_0.
apply Zpower_ge_0.
generalize (Zdigits_gt_0 beta x). omega.
generalize (Zdigits_gt_0 beta y). omega.
Qed.

Theorem Zdigits_div_Zpower :
  forall m e,
  (0 <= m)%Z ->
  (0 <= e <= Zdigits beta m)%Z ->
  Zdigits beta (m / Zpower beta e) = (Zdigits beta m - e)%Z.
Proof.
intros m e Hm He.
destruct (Zle_lt_or_eq 0 m Hm) as [Hm'|Hm'].
(* *)
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
(* . *)
unfold Zminus.
rewrite <- ln_beta_F2R_Zdigits.
2: now apply Zgt_not_eq.
assert (Hp: (0 < Zpower beta e)%Z).
apply lt_Z2R.
rewrite Z2R_Zpower with (1 := proj1 He).
apply bpow_gt_0.
rewrite Zdigits_ln_beta.
rewrite <- Zfloor_div with (1 := Zgt_not_eq _ _ Hp).
rewrite Z2R_Zpower with (1 := proj1 He).
unfold Rdiv.
rewrite <- bpow_opp.
change (Z2R m * bpow (-e))%R with (F2R (Float beta m (-e))).
destruct (ln_beta beta (F2R (Float beta m (-e)))) as (e', E').
simpl.
specialize (E' (Rgt_not_eq _ _ (F2R_gt_0_compat beta (Float beta m (-e)) Hm'))).
apply ln_beta_unique.
rewrite Rabs_pos_eq in E'.
2: now apply F2R_ge_0_compat.
rewrite Rabs_pos_eq.
split.
assert (H': (0 <= e' - 1)%Z).
(* .. *)
cut (1 <= e')%Z. omega.
apply bpow_lt_bpow with beta.
apply Rle_lt_trans with (2 := proj2 E').
simpl.
rewrite <- (Rinv_r (bpow e)).
rewrite <- bpow_opp.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- Z2R_Zpower with (1 := proj1 He).
apply Z2R_le.
rewrite <- Zabs_eq with (1 := Hm).
now apply Zpower_le_Zdigits.
apply Rgt_not_eq.
apply bpow_gt_0.
(* .. *)
rewrite <- Z2R_Zpower with (1 := H').
apply Z2R_le.
apply Zfloor_lub.
rewrite Z2R_Zpower with (1 := H').
apply E'.
apply Rle_lt_trans with (2 := proj2 E').
apply Zfloor_lb.
apply (Z2R_le 0).
apply Zfloor_lub.
now apply F2R_ge_0_compat.
apply Zgt_not_eq.
apply Zlt_le_trans with (beta^e / beta^e)%Z.
rewrite Z_div_same_full.
apply refl_equal.
now apply Zgt_not_eq.
apply Z_div_le.
now apply Zlt_gt.
rewrite <- Zabs_eq with (1 := Hm).
now apply Zpower_le_Zdigits.
(* . *)
unfold Zminus.
rewrite He', Zplus_opp_r.
rewrite Zdiv_small.
apply refl_equal.
apply conj with (1 := Hm).
pattern m at 1 ; rewrite <- Zabs_eq with (1 := Hm).
apply Zpower_gt_Zdigits.
apply Zle_refl.
(* *)
revert He.
rewrite <- Hm'.
intros (H1, H2).
simpl.
now rewrite (Zle_antisym _ _ H2 H1).
Qed.

End Fcalc_digits.

Definition radix2 := Build_radix 2 (refl_equal _).

Theorem Z_of_nat_S_digits2_Pnat :
  forall m : positive,
  Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m).
Proof.
intros m.
rewrite Zdigits_ln_beta. 2: easy.
apply sym_eq.
apply ln_beta_unique.
generalize (digits2_Pnat m) (digits2_Pnat_correct m).
intros d H.
simpl in H.
replace (Z_of_nat (S d) - 1)%Z with (Z_of_nat d).
rewrite <- Z2R_abs.
rewrite <- 2!Z2R_Zpower_nat.
split.
now apply Z2R_le.
now apply Z2R_lt.
rewrite inj_S.
apply Zpred_succ.
Qed.


Require Import Term.
Require Import Id.
Require Import FreeVars.

(* Capture-avoiding substitution *)
Inductive CAS : term -> id -> id -> term -> Prop :=
  | CAS_Var1 : forall x y, CAS (Var x) x y (Var y)
  | CAS_Var2 : forall x y z, z <> x -> CAS (Var z) x y (Var z)
  | CAS_App  : forall A B A' B' x y, CAS A x y A' -> CAS B x y B' -> CAS (App A B) x y (App A' B')
  | CAS_Lam1 : forall A x y, CAS (Lam x A) x y (Lam x A)
  | CAS_Lam2 : forall A x y z, not x ?? A -> CAS (Lam z A) x y (Lam z A)
  | CAS_Lam3 : forall A A' x y z, z <> x -> z <> y -> CAS A x y A' -> CAS (Lam z A) x y (Lam z A')
  | CAS_Lam4 : forall A A' A'' x y z, not z ?? A -> CAS A y z A'' -> CAS A'' x y A' -> CAS (Lam y A) x y (Lam z A')
.

Hint Constructors CAS.

Lemma CAS_same: forall A B x, CAS A x x B -> A = B.
Proof.
  intros.
  admit.
Admitted.

Lemma CAS_refl: forall A x, CAS A x x A.
Proof.
  intros.
  admit.
Admitted.

Lemma CAS_other: forall A x y, not x ?? A -> not y ?? A -> CAS A x y A.
Proof.
  intros.
  induction A.
  - apply CAS_Var2.
    apply FV_Var_other2 in H. auto.
  - assert (not x ?? A1). { apply FV_App_not1 in H. auto. }
    assert (not x ?? A2). { apply FV_App_not2 in H. auto. }
    assert (not y ?? A1). { apply FV_App_not1 in H0. auto. }
    assert (not y ?? A2). { apply FV_App_not2 in H0. auto. }
    auto.
  - destruct (eq_id_dec x i).
    + subst. auto.
    + destruct (eq_id_dec y i). subst.
      * remember (CAS_Lam2 A x i i).
        assert (not x ?? A). { remember (FV_Lam_body A x i). auto. }
        auto.
      * remember (CAS_Lam2 A x y i).
        assert (not x ?? A). { remember (FV_Lam_body A x i). auto. }
        auto.
Qed.

Lemma CAS_symm: forall A B x y, not y ?? A -> CAS A x y B -> CAS B y x A.
Proof.
    intros.
    destruct (eq_id_dec x y).
    subst. assert (A = B). { remember (CAS_same A B y). auto. }
    subst. auto.

    induction A.
    - inversion H0. subst.
      + auto.
      + subst. apply CAS_other.
        destruct (eq_id_dec y i).
        * subst. exfalso. apply FV_Var_other2 in H. auto.
        * auto.
        * apply FV_Var_other1. auto.

    - assert (not y ?? A1). { apply FV_App_not1 in H. auto. }
      assert (not y ?? A2). { apply FV_App_not2 in H. auto. }
      inversion H0.
      subst.
      admit.
    - admit.
Admitted.

Lemma CAS_symm_var : forall A B x y, not y ?? A -> CAS A x y B -> not x ?? B.
Proof.
  intros.
  admit.
Admitted.

Lemma CAS_deterministic : forall A B C x y, CAS A x y B -> CAS A x y C -> B = C.
Proof.
  admit.
Admitted.

Lemma CAS_subst_other : forall A B x y z, x <> z -> CAS A x y B -> not z ?? B -> not z ?? A.
Proof.
  admit.
Admitted.

Lemma CAS_comp : forall A B C x y z, CAS A x y B -> CAS B y z C -> CAS A x z C.
Proof.
  admit.
Admitted.


Require Import Flocq.Core.Fcore.
Require Import Flocq.Prop.Fprop_Sterbenz.
Require Import Gappa_common.
Require Import Gappa_round_aux.

Theorem fix_subset :
  forall x : R, forall xn zn : Z,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX x zn.
Proof.
intros x xn zn Hx Hb.
apply fix_le with (1 := Hx).
now apply Zle_bool_imp_le.
Qed.

Theorem flt_subset :
  forall x : R, forall xn zn : positive,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT x zn.
Proof.
intros x xn zn Hx Hb.
apply flt_le with (1 := Hx).
now apply Zle_bool_imp_le.
Qed.

Definition fix_of_singleton_bnd_helper (xi : FF) (n : Z) :=
 Zeq_bool (Fnum (lower xi)) (Fnum (upper xi)) &&
 Zeq_bool (Fexp (lower xi)) (Fexp (upper xi)) &&
 Zle_bool n (Fexp (lower xi)).

Theorem fix_of_singleton_bnd :
 forall x : R, forall xi : FF, forall n : Z,
 ABS x xi ->
 fix_of_singleton_bnd_helper xi n = true ->
 FIX x n.
Proof.
intros x xi n (_, (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zeq_bool_correct_t _ _ H1). clear H1. intro H1.
generalize (Zeq_bool_correct_t _ _ H2). clear H2. intro H2.
generalize (Zle_bool_imp_le _ _ H3). clear H3. intro H3.
assert (float2R (lower xi) = Rabs x).
apply Rle_antisym.
exact Hx1.
replace (lower xi) with (upper xi).
exact Hx2.
apply sym_equal.
induction (lower xi). induction (upper xi).
exact (f_equal2 _ H1 H2).
unfold Rabs in H.
induction (Rcase_abs x).
exists (Fopp2 (lower xi)).
split.
rewrite Fopp2_correct.
rewrite <- (Ropp_involutive x).
apply Ropp_eq_compat.
exact H.
exact H3.
exists (lower xi).
exact (conj H H3).
Qed.

Definition flt_of_singleton_bnd_helper (xi : FF) (n : positive) :=
 Zeq_bool (Fnum (lower xi)) (Fnum (upper xi)) &&
 Zeq_bool (Fexp (lower xi)) (Fexp (upper xi)) &&
 Zlt_bool (Zabs (Fnum (lower xi))) (two_power_pos n).

Theorem flt_of_singleton_bnd :
 forall x : R, forall xi : FF, forall n : positive,
 ABS x xi ->
 flt_of_singleton_bnd_helper xi n = true ->
 FLT x n.
Proof.
intros x xi n (_, (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zeq_bool_correct_t _ _ H1). clear H1. intro H1.
generalize (Zeq_bool_correct_t _ _ H2). clear H2. intro H2.
generalize (Zlt_cases (Zabs (Fnum (lower xi))) (two_power_pos n)). rewrite H3. rewrite two_power_pos_correct. clear H3. intro H3.
assert (float2R (lower xi) = Rabs x).
apply Rle_antisym.
exact Hx1.
replace (lower xi) with (upper xi).
exact Hx2.
apply sym_equal.
induction (lower xi). induction (upper xi).
exact (f_equal2 _ H1 H2).
unfold Rabs in H.
induction (Rcase_abs x).
exists (Fopp2 (lower xi)).
split.
rewrite Fopp2_correct.
rewrite <- (Ropp_involutive x).
apply Ropp_eq_compat.
exact H.
simpl.
rewrite Zabs_Zopp.
exact H3.
exists (lower xi).
exact (conj H H3).
Qed.

Theorem neg_fix :
  forall x : R, forall xn zn : Z,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (-x)%R zn.
Proof.
intros x xn zn [fx [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
exists (Fopp2 fx).
split.
rewrite <- Hx1.
apply Fopp2_correct.
now apply Zle_trans with xn.
Qed.

Theorem abs_fix :
  forall x : R, forall xn zn : Z,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (Rabs x) zn.
Proof.
intros x xn zn [[mx ex] [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
exists (Float2 (Zabs mx) ex).
split.
rewrite <- Hx1.
apply F2R_Zabs.
now apply Zle_trans with xn.
Qed.

Definition add_fix_helper (xn yn zn : Z) :=
 Zle_bool zn xn &&
 Zle_bool zn yn.

Theorem add_fix :
 forall x y : R, forall xn yn zn : Z,
 FIX x xn -> FIX y yn ->
 add_fix_helper xn yn zn = true ->
 FIX (x + y)%R zn.
Proof.
intros x y xn yn zn (fx,(Hx1,Hx2)) (fy,(Hy1,Hy2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
exists (Fplus2 fx fy).
split.
rewrite <- Hx1.
rewrite <- Hy1.
apply Fplus2_correct.
unfold Fplus2, Fshift2.
case (Fexp fx - Fexp fy)%Z ; intros.
exact (Zle_trans _ _ _ H1 Hx2).
exact (Zle_trans _ _ _ H2 Hy2).
exact (Zle_trans _ _ _ H1 Hx2).
Qed.

Theorem sub_fix :
 forall x y : R, forall xn yn zn : Z,
 FIX x xn -> FIX y yn ->
 add_fix_helper xn yn zn = true ->
 FIX (x - y)%R zn.
Proof.
intros x y xn yn zn Hx (fy,(Hy1,Hy2)) Hb.
unfold Rminus.
apply (add_fix _ (-y) _ yn zn Hx).
exists (Fopp2 fy).
split.
rewrite <- Hy1.
apply Fopp2_correct.
exact Hy2.
exact Hb.
Qed.

Theorem mul_fix :
 forall x y : R, forall xn yn zn : Z,
 FIX x xn -> FIX y yn ->
 Zle_bool zn (xn + yn) = true ->
 FIX (x * y)%R zn.
Proof.
intros x y xn yn zn (fx,(Hx1,Hx2)) (fy,(Hy1,Hy2)) Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
exists (Fmult2 fx fy).
split.
rewrite <- Hx1. rewrite <- Hy1.
apply Fmult2_correct.
apply Zle_trans with (1 := H1).
exact (Zplus_le_compat _ _ _ _ Hx2 Hy2).
Qed.

Lemma flt_abs_aux :
  forall x : R, forall xn : positive,
  FLT (Rabs x) xn <-> FLT x xn.
Proof.
intros x xn.
unfold Rabs.
case Rcase_abs ; intros Hx.
2: easy.
split ; intros [[mx ex] [Hx1 Hx2]] ;
  exists (Float2 (Zopp mx) ex) ; split ; simpl.
rewrite <- (Ropp_involutive x), <- Hx1.
apply F2R_Zopp.
now rewrite Zabs_Zopp.
rewrite <- Hx1.
apply F2R_Zopp.
now rewrite Zabs_Zopp.
Qed.

Lemma flt_1_aux :
  forall x y : R, forall yn : positive,
  FLT x 1 -> FLT y yn ->
  FLT (x * y)%R yn.
Proof.
intros x y yn [[mx ex] [<- Hx]] Hy.
destruct mx as [|mx|mx].
rewrite float2_zero, Rmult_0_l.
exists (Float2 Z0 0).
split.
apply float2_zero.
now apply (Zpower_gt_0 radix2 (Zpos yn)).
destruct mx ; try now destruct mx.
destruct Hy as [[my ey] [<- Hy]].
exists (Float2 my (ex + ey)).
split.
2: exact Hy.
unfold float2R ; simpl.
rewrite <- Fcalc_ops.F2R_mult.
unfold Fcalc_ops.Fmult.
now rewrite Zmult_1_l.
destruct mx ; try now destruct mx.
destruct Hy as [[my ey] [<- Hy]].
exists (Float2 (-my) (ex + ey)).
split.
2: simpl ; now rewrite Zabs_Zopp.
unfold float2R ; simpl.
rewrite <- Fcalc_ops.F2R_mult.
unfold Fcalc_ops.Fmult.
now replace (-1 * my)%Z with (Zopp my) by ring.
Qed.

Theorem mul_flt :
  forall x y : R, forall xn yn zn : positive,
  FLT x xn -> FLT y yn ->
  Zle_bool (Zpos (if xn =? 1 then yn else if yn =? 1 then xn else xn + yn)%positive) (Zpos zn) = true ->
  FLT (x * y)%R zn.
Proof.
intros x y xn yn zn Hx Hy Hb.
apply Zle_bool_imp_le in Hb.
revert Hb.
apply flt_le.
case Pos.eqb_spec.
intros ->.
now apply flt_1_aux.
intros _.
case Pos.eqb_spec.
intros ->.
rewrite Rmult_comm.
now apply flt_1_aux.
intros _.
destruct Hx as [fx [Hx1 Hx2]].
destruct Hy as [fy [Hy1 Hy2]].
exists (Fmult2 fx fy).
split.
rewrite <- Hx1. rewrite <- Hy1.
apply Fmult2_correct.
change (Z.pow_pos 2 (xn + yn)) with (Zpower radix2 (Zpos xn + Zpos yn)).
rewrite Zpower_plus by easy.
simpl Zabs.
rewrite Zabs_Zmult.
apply Zmult_lt_compat ; split ;
  try assumption ; apply Zabs_pos.
Qed.

Theorem fix_of_flt_bnd :
 forall x : R, forall xi : FF, forall n : Z, forall p : positive,
 FLT x p -> ABS x xi ->
 Zle_bool (n + Zpos p) (Zpos (digits (pos_of_Z (Fnum (lower xi)))) + Fexp (lower xi))
 && Fpos (lower xi) = true ->
 FIX x n.
Proof.
intros x ((ml,el),xu) n p ((mx,ex),(Hx1,Hx2)) (_,(Hxi,_)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). simpl Fnum. simpl Fexp. clear H1. intro H1.
generalize (Fpos_correct _ H2). simpl. clear H2. intro H2.
exists (Float2 mx ex).
split.
exact Hx1.
apply Zplus_le_reg_l with (Zpos p).
rewrite Zplus_comm.
apply Zle_trans with (1 := H1). clear H1.
rewrite digits2_digits.
assert (H0: (0 < ml)%Z).
apply F2R_gt_0_reg with (1 := H2).
rewrite Zpos_pos_of_Z with (1 := H0).
assert (H0': ml <> Z0).
intros H.
now rewrite H in H0.
rewrite Fcalc_digits.Zdigits_ln_beta with (1 := H0').
rewrite <- ln_beta_F2R with (1 := H0').
apply Zle_trans with (ln_beta radix2 (Rabs (Float2 mx ex))).
apply ln_beta_le.
now apply F2R_gt_0_compat.
now rewrite Hx1.
rewrite ln_beta_abs.
unfold float2R.
assert (Hx0: mx <> Z0).
intros H.
apply Rle_not_lt with (1 := Hxi).
rewrite <- Hx1, H.
unfold float2R.
rewrite F2R_0, Rabs_R0.
now apply F2R_gt_0_compat.
rewrite ln_beta_F2R with (1 := Hx0).
apply Zplus_le_compat_r.
destruct (ln_beta radix2 (Z2R mx)) as (e, He).
simpl.
apply bpow_lt_bpow with radix2.
apply Rle_lt_trans with (Rabs (Z2R mx)).
apply He.
now apply (Z2R_neq _ 0).
rewrite <- Z2R_abs.
rewrite <- Z2R_Zpower. 2: easy.
now apply Z2R_lt.
Qed.

Theorem flt_of_fix_bnd :
  forall x xi n p,
  FIX x n -> ABS x xi ->
  Zle_bool (Zpos (digits (pos_of_Z (Fnum (upper xi)))) + Fexp (upper xi)) (n + Zpos p) = true ->
  FLT x p.
Proof.
intros x (xl,(mu,eu)) n p ((m,e),(Hx1,Hx2)) Hxi H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
exists (Float2 m e).
split.
exact Hx1.
unfold float2R in Hx1. simpl in Hx1.
simpl Fnum in H. simpl Fexp in H.
apply (F2R_lt_reg radix2 e).
rewrite F2R_Zabs.
apply Rle_lt_trans with (F2R (Float radix2 mu eu)).
simpl. rewrite Hx1.
apply Hxi.
apply Rlt_le_trans with (bpow radix2 (n + Zpos p)).
destruct (Zle_or_lt mu 0) as [Hu|Hu].
apply Rle_lt_trans with R0.
now apply F2R_le_0_compat.
apply bpow_gt_0.
apply Rlt_le_trans with (bpow radix2 (Fcore_digits.Zdigits radix2 mu + eu)).
rewrite Fcalc_digits.Zdigits_ln_beta. 2: intros Hu' ; now rewrite Hu' in Hu.
rewrite <- ln_beta_F2R. 2: intros Hu' ; now rewrite Hu' in Hu.
destruct (ln_beta radix2 (F2R (Float radix2 mu eu))) as (e', He).
apply (Rle_lt_trans _ _ _ (RRle_abs _)).
apply He.
apply Rgt_not_eq.
now apply F2R_gt_0_compat.
rewrite <- (Zpos_pos_of_Z _ Hu).
rewrite <- digits2_digits.
now apply bpow_le.
unfold F2R. simpl.
change (Zpower_pos 2 p) with (Zpower radix2 (Zpos p)).
rewrite Z2R_Zpower. 2: easy.
rewrite <- bpow_plus.
apply bpow_le.
rewrite Zplus_comm.
now apply Zplus_le_compat_l.
Qed.

Definition sub_flt_helper (xn yn zn : positive) (xyi : FF) :=
  Zle_bool (Zpos xn) (Zpos zn) &&
  Zle_bool (Zpos yn) (Zpos zn) &&
  Fle2 (Float2 (-1) (-1)) (lower xyi) &&
  Fle2 (upper xyi) (Float2 1 0).

Theorem sub_flt :
  forall x y xn yn xyi zn,
  FLT x xn -> FLT y yn -> REL x y xyi ->
  sub_flt_helper xn yn zn xyi = true ->
  FLT (x - y) zn.
Proof.
intros x y xn yn xyi zn Hx Hy (eps,((Hxy1,Hxy2),Hxy3)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
generalize (Fle2_correct _ _ H4). clear H4. intro H4.
destruct (total_order_T y 0) as [[Zy|Zy]|Zy].
(* *)
apply <- FLT_iff_generic.
unfold Rminus.
rewrite <- (Ropp_involutive x), Rplus_comm.
apply sterbenz.
apply FLX_exp_monotone.
apply generic_format_opp.
apply -> FLT_iff_generic.
now apply flt_subset with yn.
apply generic_format_opp.
apply -> FLT_iff_generic.
now apply flt_subset with xn.
rewrite Hxy3, <- Ropp_mult_distr_l_reverse.
unfold Rdiv.
rewrite (Rmult_comm 2), 2!Rmult_assoc.
pattern (-y)%R at 2 3 ; rewrite <- Rmult_1_r.
assert (Zy': (0 <= -y)%R).
apply Rlt_le.
now apply Ropp_0_gt_lt_contravar.
split ; apply Rmult_le_compat_l ; try easy.
apply Rmult_le_reg_r with 2%R.
now apply (Z2R_lt 0 2).
rewrite Rmult_assoc, Rinv_l, Rmult_1_l, Rmult_1_r.
apply Rplus_le_compat_l.
apply Rle_trans with (1 := Hxy2).
now rewrite <- (Rmult_1_r 1).
apply Rgt_not_eq.
now apply (Z2R_lt 0 2).
pattern R1 at 1 ; replace R1 with ((1 + -1 / 2)*2)%R by field.
apply Rmult_le_compat_r.
now apply (Z2R_le 0 2).
apply Rplus_le_compat_l.
now apply Rle_trans with (2 := Hxy1).
(* *)
rewrite Zy, Rminus_0_r.
now apply flt_subset with xn.
(* *)
apply <- FLT_iff_generic.
apply sterbenz.
apply FLX_exp_monotone.
apply -> FLT_iff_generic.
now apply flt_subset with xn.
apply -> FLT_iff_generic.
now apply flt_subset with yn.
rewrite Hxy3.
unfold Rdiv.
rewrite (Rmult_comm 2).
assert (Zy': (0 <= y)%R).
now apply Rlt_le.
split ; apply Rmult_le_compat_l ; try easy.
replace (/2)%R with (1 + -1/2)%R by field.
apply Rplus_le_compat_l.
now apply Rle_trans with (2 := Hxy1).
apply Rplus_le_compat_l.
apply Rle_trans with (1 := Hxy2).
now rewrite <- (Rmult_1_r 1).
Qed.

Theorem sub_flt_rev :
  forall x y xn yn xyi zn,
  FLT x xn -> FLT y yn -> REL x y xyi ->
  sub_flt_helper xn yn zn xyi = true ->
  FLT (y - x) zn.
Proof.
intros x y xn yn xyi zn Hx Hy Hxy Hb.
apply <- FLT_iff_generic.
rewrite <- Ropp_minus_distr.
apply generic_format_opp.
apply -> FLT_iff_generic.
eapply sub_flt ; eassumption.
Qed.


(**
*  CS386L Programming Languages
* Final project
* Tian Zhang (tz3272)
* Brief Introduction:
*     For the this file, I am working on for while loop equivalence, and
      all the work is based on Maps, Imp in class. I got some idea from
      the midterm
*)

Require Import ProgramEquivalence.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.
Require Import Maps.
Require Import Imp.

(** In midterm, we extends the optional add_for_loop exercise from
    the [Imp] chapter, and we were asked to extend the language
    of commands with C-style for loops. Now I want to prove that
    for command and while command are equivalent, that is
    the command:

      for (c1 ; b ; c2) {
          c3
      }

    is equivalent to:

       c1 ;
       WHILE b DO
         c3 ;
         c2
       END
   are equivalent
*)

(** first of all , we will add the definition for for loop *)

Inductive com' : Type :=
  | CSkip' : com'
  | CAss' : id -> aexp -> com'
  | CSeq' : com' -> com' -> com'
  | CIf' : bexp -> com' -> com' -> com'
  | CWhile' : bexp -> com' -> com'
  | CFor' : com' -> bexp -> com' -> com' -> com'.

Inductive ceval' : com' -> state -> state -> Prop :=
  | E_Skip' : forall st,
      ceval' CSkip' st st
  | E_Ass' : forall st a1 n x,
      aeval st a1 = n ->
      ceval' (CAss' x a1) st (t_update st x n)
  | E_Seq' : forall c1 c2 st st' st'',
      ceval' c1 st st' ->
      ceval' c2 st' st'' ->
      ceval' (CSeq' c1 c2) st st''
  | E_IfTrue' : forall st st' b c1 c2,
      beval st b = true ->
      ceval' c1 st st' ->
      ceval' (CIf' b c1 c2) st st'
  | E_IfFalse' : forall st st' b c1 c2,
      beval st b = false ->
      ceval' c2 st st' ->
      ceval' (CIf' b c1 c2) st st'
  | E_WhileEnd' : forall b st c,
      beval st b = false ->
      ceval' (CWhile' b c) st st
  | E_WhileLoop' : forall st st' st'' b c,
      beval st b = true ->
      ceval' c st st' ->
      ceval' (CWhile' b c) st' st'' ->
      ceval' (CWhile' b c) st st''
  | E_For' : forall st st' st'' b c1 c2 c3,
      ceval' c1 st st' ->
      ceval' (CWhile' b (CSeq' c2 c3)) st' st'' ->
      ceval' (CFor' c1 b c2 c3) st st''.

(** Next step is to prove that those two programs are equivalent*)

Definition cequiv_for_while (c1 c2 : com') : Prop :=
  forall st st' : state, ceval' c1 st st' <-> ceval' c2 st st'.

Theorem for_while_equiv : forall b c1 c2 c3,
  cequiv_for_while (CFor' c1 b c2 c3) (CSeq' c1 (CWhile' b (CSeq' c2 c3))).
Proof.
  unfold cequiv_for_while.
  split; intros.
  - (* -> *)
    inversion H; subst.
    apply E_Seq' with st'0.
    apply H6.
    apply H7.
  - (* <- *)
    inversion H; subst.
    apply E_For' with st'0.
    apply H2.
    apply H5.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Lists.List.
Require Import Crypto.Util.Decidable.
Require Export Crypto.Util.FixCoqMistakes.

Fixpoint tuple' T n : Type :=
  match n with
  | O => T
  | S n' => (tuple' T n' * T)%type
  end.

Definition tuple T n : Type :=
  match n with
  | O => unit
  | S n' => tuple' T n'
  end.

Fixpoint to_list' {T} (n:nat) {struct n} : tuple' T n -> list T :=
  match n with
  | 0 => fun x => (x::nil)%list
  | S n' => fun xs : tuple' T (S n') => (snd xs :: to_list' n' (fst xs))%list
  end.

Definition to_list {T} (n:nat) : tuple T n -> list T :=
  match n with
  | 0 => fun _ => nil
  | S n' => fun xs : tuple T (S n') => to_list' n' xs
  end.

Program Fixpoint from_list' {T} (y:T) (n:nat) (xs:list T) : length xs = n -> tuple' T n :=
  match n return _ with
  | 0 =>
    match xs return (length xs = 0 -> tuple' T 0) with
    | nil => fun _ => y
    | _ => _ (* impossible *)
    end
  | S n' =>
    match xs return (length xs = S n' -> tuple' T (S n')) with
    | cons x xs' => fun _ => (from_list' x n' xs' _, y)
    | _ => _ (* impossible *)
    end
  end.

Program Definition from_list {T} (n:nat) (xs:list T) : length xs = n -> tuple T n :=
match n return _ with
| 0 =>
    match xs return (length xs = 0 -> tuple T 0) with
    | nil => fun _ : 0 = 0 => tt
    | _ => _ (* impossible *)
    end
| S n' =>
    match xs return (length xs = S n' -> tuple T (S n')) with
    | cons x xs' => fun _ => from_list' x n' xs' _
    | _ => _ (* impossible *)
    end
end.

Lemma to_list_from_list : forall {T} (n:nat) (xs:list T) pf, to_list n (from_list n xs pf) = xs.
Proof.
  destruct xs; simpl; intros; subst; auto.
  generalize dependent t. simpl in *.
  induction xs; simpl in *; intros; congruence.
Qed.

Lemma length_to_list' T n t : length (@to_list' T n t) = S n.
Proof. induction n; simpl in *; trivial; destruct t; simpl; congruence. Qed.

Lemma length_to_list : forall {T} {n} (xs:tuple T n), length (to_list n xs) = n.
Proof.
  destruct n; [ reflexivity | apply length_to_list' ].
Qed.

Lemma from_list'_to_list' : forall T n (xs:tuple' T n),
    forall x xs' pf, to_list' n xs = cons x xs' ->
      from_list' x n xs' pf = xs.
Proof.
  induction n; intros.
  { simpl in *. injection H; clear H; intros; subst. congruence. }
  { destruct xs eqn:Hxs;
    destruct xs' eqn:Hxs';
    injection H; clear H; intros; subst; try discriminate.
    simpl. f_equal. eapply IHn. assumption. }
Qed.

Lemma from_list_to_list : forall {T n} (xs:tuple T n) pf, from_list n (to_list n xs) pf = xs.
Proof.
  destruct n; auto; intros; simpl in *.
  { destruct xs; auto. }
  { destruct (to_list' n xs) eqn:H; try discriminate.
    eapply from_list'_to_list'; assumption. }
Qed.

Definition on_tuple {A B} (f:list A -> list B)
           {n m:nat} (H:forall xs, length xs = n -> length (f xs) = m)
           (xs:tuple A n) : tuple B m :=
  from_list m (f (to_list n xs))
            (H (to_list n xs) (length_to_list xs)).

Definition map {n A B} (f:A -> B) (xs:tuple A n) : tuple B n
  := on_tuple (List.map f) (fun _ => eq_trans (map_length _ _)) xs.

Definition on_tuple2 {A B C} (f : list A -> list B -> list C) {a b c : nat}
           (Hlength : forall la lb, length la = a -> length lb = b -> length (f la lb) = c)
           (ta:tuple A a) (tb:tuple B b) : tuple C c
  := from_list c (f (to_list a ta) (to_list b tb))
               (Hlength (to_list a ta) (to_list b tb) (length_to_list ta) (length_to_list tb)).

Fixpoint fieldwise' {A B} (n:nat) (R:A->B->Prop) (a:tuple' A n) (b:tuple' B n) {struct n} : Prop.
  destruct n; simpl @tuple' in *.
  { exact (R a b). }
  { exact (R (snd a) (snd b) /\ fieldwise' _ _ n R (fst a) (fst b)). }
Defined.

Definition fieldwise {A B} (n:nat) (R:A->B->Prop) (a:tuple A n) (b:tuple B n) : Prop.
  destruct n; simpl @tuple in *.
  { exact True. }
  { exact (fieldwise' _ R a b). }
Defined.

Global Instance Equivalence_fieldwise' {A} {R:relation A} {R_equiv:Equivalence R} {n:nat}:
    Equivalence (fieldwise' n R).
Proof.
  induction n as [|? IHn]; [solve [auto]|].
  (* could use [dintuition] in 8.5 only, and remove the [destruct] *)
  destruct IHn, R_equiv; simpl; constructor; repeat intro; intuition eauto.
Qed.

Global Instance Equivalence_fieldwise {A} {R:relation A} {R_equiv:Equivalence R} {n:nat}:
    Equivalence (fieldwise n R).
Proof.
  destruct n; (repeat constructor || apply Equivalence_fieldwise').
Qed.

Arguments fieldwise' {A B n} _ _ _.
Arguments fieldwise {A B n} _ _ _.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Global Instance dec_fieldwise' {A RA} {HA : DecidableRel RA} {n} : DecidableRel (@fieldwise' A A n RA) | 10.
Proof.
  induction n; simpl @fieldwise'.
  { exact _. }
  { intros ??.
    exact _. }
Defined.

Global Instance dec_fieldwise {A RA} {HA : DecidableRel RA} {n} : DecidableRel (@fieldwise A A n RA) | 10.
Proof.
  destruct n; unfold fieldwise; exact _.
Defined.

Fixpoint fieldwiseb' {A B} (n:nat) (R:A->B->bool) (a:tuple' A n) (b:tuple' B n) {struct n} : bool.
  destruct n; simpl @tuple' in *.
  { exact (R a b). }
  { exact (R (snd a) (snd b) && fieldwiseb' _ _ n R (fst a) (fst b))%bool. }
Defined.

Definition fieldwiseb {A B} (n:nat) (R:A->B->bool) (a:tuple A n) (b:tuple B n) : bool.
  destruct n; simpl @tuple in *.
  { exact true. }
  { exact (fieldwiseb' _ R a b). }
Defined.

Arguments fieldwiseb' {A B n} _ _ _.
Arguments fieldwiseb {A B n} _ _ _.

Lemma fieldwiseb'_fieldwise' :forall {A B} n R Rb
                                   (a:tuple' A n) (b:tuple' B n),
  (forall a b, Rb a b = true <-> R a b) ->
  (fieldwiseb' Rb a b = true <-> fieldwise' R a b).
Proof.
  intros.
  revert n a b;
  induction n; intros; simpl @tuple' in *;
    simpl fieldwiseb'; simpl fieldwise'; auto.
  cbv beta.
  rewrite Bool.andb_true_iff.
  f_equiv; auto.
Qed.

Lemma fieldwiseb_fieldwise :forall {A B} n R Rb
                                   (a:tuple A n) (b:tuple B n),
  (forall a b, Rb a b = true <-> R a b) ->
  (fieldwiseb Rb a b = true <-> fieldwise R a b).
Proof.
  intros; destruct n; simpl @tuple in *;
    simpl @fieldwiseb; simpl @fieldwise; try tauto.
  auto using fieldwiseb'_fieldwise'.
Qed.

Fixpoint from_list_default' {T} (d y:T) (n:nat) (xs:list T) : tuple' T n :=
  match n return tuple' T n with
  | 0 => y (* ignore high digits *)
  | S n' =>
         match xs return _ with
         | cons x xs' => (from_list_default' d x n' xs', y)
         | nil => (from_list_default' d d n' nil, y)
         end
  end.

Definition from_list_default {T} d (n:nat) (xs:list T) : tuple T n :=
match n return tuple T n with
| 0 => tt
| S n' =>
    match xs return _ with
    | cons x xs' => (from_list_default' d x n' xs')
    | nil => (from_list_default' d d n' nil)
    end
end.

Lemma from_list_default'_eq : forall {T} (d : T) xs n y pf,
  from_list_default' d y n xs = from_list' y n xs pf.
Proof.
  induction xs; destruct n; intros; simpl in *;
    solve [ congruence (* 8.5 *)
          | erewrite IHxs; reflexivity ]. (* 8.4 *)
Qed.

Lemma from_list_default_eq : forall {T} (d : T) xs n pf,
  from_list_default d n xs = from_list n xs pf.
Proof.
  induction xs; destruct n; intros; try solve [simpl in *; congruence].
  apply from_list_default'_eq.
Qed.

Fixpoint function R T n : Type :=
  match n with
  | O => R
  | S n' => T -> function R T n'
  end.

Fixpoint apply' {R T} (n:nat) : (T -> function R T n) -> tuple' T n -> R :=
  match n with
  | 0 => id
  | S n' => fun f x => apply' n' (f (snd x)) (fst x)
  end.

Definition apply {R T} (n:nat) : function R T n -> tuple T n -> R :=
  match n with
  | O => fun r _ => r
  | S n' => fun f x =>  apply' n' f x
  end.

Require Import Coq.Lists.SetoidList.

Lemma fieldwise_to_list_iff : forall {T n} R (s t : tuple T n),
    (fieldwise R s t <-> Forall2 R (to_list _ s) (to_list _ t)).
Proof.
  induction n; split; intros.
  + constructor.
  + cbv [fieldwise]. auto.
  + destruct n; cbv [tuple to_list fieldwise] in *.
    - cbv [to_list']; auto.
    - simpl in *.
      constructor; intuition auto.
      apply IHn; auto.
  + destruct n; cbv [tuple to_list fieldwise] in *.
    - cbv [fieldwise']; auto.
      cbv [to_list'] in *; inversion H; auto.
    - simpl in *.
      inversion H; subst.
      split; try assumption.
      apply IHn; auto.
Qed.

Require Import Crypto.Util.ListUtil. (* To initialize [distr_length] database *)
Hint Rewrite length_to_list' @length_to_list : distr_length.


From Coq Require Import
  Lia.
From TinyRAM.Utils Require Import
  Vectors.
From TinyRAM.Utils Require Import
  BitVectors.
From TinyRAM.Utils Require Import
  Fin.
From TinyRAM.Machine Require Import
  Parameters.
From TinyRAM.Machine Require Import
  Coding.
Import PeanoNat.Nat.

Module TinyRAMMem (Params : TinyRAMParameters).
  Module TRCod := TinyRAMCoding Params.
  Import TRCod.
  Export TRCod.

  (*"""
  Memory, which is a linear array of 2^[wordSize] bytes.
  """*)
  Definition Memory := VectorDef.t Byte (2 ^ wordSize).

  (*"""
  We say that a block is aligned to the A-th byte if its
  least-significant byte is at address A.
  """*)

  (*"""
  When storing or loading blocks of multiple bytes,
  [...] the least-significant byte is at the lowest address.
  """*)
  Definition Memory_Block_Load
    (m : Memory)
    (idx blksz : fin (2 ^ wordSize)) :
    VectorDef.t Byte (proj1_sig blksz) :=
    VectorDef.rev (Block_Load m idx blksz).

  (*"""
  When storing or loading blocks of multiple bytes,
  [...] the least-significant byte is at the lowest address.
  """*)
  Definition Memory_Block_Store
    (m : Memory)
    (idx blksz : fin (2 ^ wordSize))
    (block : VectorDef.t Byte (proj1_sig blksz)) :
    Memory :=
    Block_Store m idx blksz (VectorDef.rev block).

  (* Since a Word is a memory block, it can be loaded as well. *)
  Definition Memory_Word_Load
    (m : Memory)
    (idx : fin (2 ^ wordSize)) :
    Word.
    unfold Word.
    apply vector_concat.
    apply (Memory_Block_Load m idx wordSizeEighthFin).
  Defined.

  (* Since a Word is a memory block, it can be stored as well. *)
  Definition Memory_Word_Store
    (m : Memory)
    (idx : fin (2 ^ wordSize))
    (reg : Word) :
    Memory.
    apply (Memory_Block_Store m idx wordSizeEighthFin).
    apply vector_unconcat, reg.
  Defined.

  Definition Register_Index (w : Word) : fin (2 ^ wordSize) :=
    bitvector_fin_big w.

  Definition Memory_Word_Load_from_Reg
    (m : Memory) (idx : Word) : Word :=
    Memory_Word_Load m (Register_Index idx).

  Definition Memory_Word_Store_from_Reg
    (m : Memory) (idx reg : Word) : Memory :=
    Memory_Word_Store m (Register_Index idx) reg.

Theorem Memory_Word_Store_Load_from_Reg: forall
    (m : Memory)
    (idx reg : Word),
    Memory_Word_Load_from_Reg
      (Memory_Word_Store_from_Reg m idx reg)
      idx
    = reg.
Proof.
  intros.
  unfold Memory_Word_Store_from_Reg, Memory_Word_Load_from_Reg.
  unfold Memory_Word_Store, Memory_Word_Load.
  unfold Memory_Block_Load, Memory_Block_Store.
  rewrite Block_Store_Load, vector_rev_rev_id, vector_concat_inv1.
  reflexivity.
Qed.

Theorem Memory_Word_Store_Store_from_Reg: forall
    (m : Memory)
    (idx reg1 reg2 : Word),
    Memory_Word_Store_from_Reg
      (Memory_Word_Store_from_Reg m idx reg1)
      idx reg2
    = Memory_Word_Store_from_Reg m idx reg2.
Proof.
  intros.
  unfold Memory_Word_Store_from_Reg, Memory_Word_Load_from_Reg.
  unfold Memory_Word_Store, Memory_Word_Load.
  unfold Memory_Block_Load, Memory_Block_Store.
  rewrite Block_Store_Store; reflexivity.
Qed.

Theorem Memory_Word_Store_Load_from_Reg_Irr : forall
    (m : Memory)
    (idx1 idx2 block: Word),
    (*  |----------------|
          |--|      |--|
          1  1+     2  2+   *)
    (((bitvector_nat_big idx1 + wordSizeEighth <= bitvector_nat_big idx2) /\
      (bitvector_nat_big idx2 + wordSizeEighth < 2 ^ wordSize)) \/
    (*  |----------------|
          |--|      |--|
          2  2+     1  1+   *)
     ((bitvector_nat_big idx2 + wordSizeEighth <= bitvector_nat_big idx1) /\
      (bitvector_nat_big idx1 + wordSizeEighth < 2 ^ wordSize)) \/
    (*  |----------------|
        -|    |--|      |-
         2+   1  1+     2   *)
     ((bitvector_nat_big idx1 + wordSizeEighth <= bitvector_nat_big idx2) /\
      ((bitvector_nat_big idx2 + wordSizeEighth) mod 2 ^ wordSize <= bitvector_nat_big idx1) /\
      (2 ^ wordSize < bitvector_nat_big idx2 + wordSizeEighth)) \/
    (*  |----------------|
        -|    |--|      |-
         1+   2  2+     1   *)
     ((bitvector_nat_big idx2 + wordSizeEighth <= bitvector_nat_big idx1) /\
      ((bitvector_nat_big idx1 + wordSizeEighth) mod 2 ^ wordSize <= bitvector_nat_big idx2)/\
      (2 ^ wordSize < bitvector_nat_big idx1   + wordSizeEighth))) ->
    Memory_Word_Load_from_Reg
      (Memory_Word_Store_from_Reg m idx1 block)
      idx2
    = Memory_Word_Load_from_Reg m idx2.
Proof.
  intros.
  unfold Memory_Word_Store_from_Reg, Memory_Word_Load_from_Reg.
  unfold Memory_Word_Store, Memory_Word_Load.
  unfold Memory_Block_Load, Memory_Block_Store.
  rewrite Block_Store_Load_Irr;[reflexivity|assumption].
Qed.

Theorem Memory_Word_Store_Store_from_Reg_Swap : forall
    (m : Memory)
    (idx1 idx2 block block': Word),
    (*  |----------------|
          |--|      |--|
          1  1+     2  2+   *)
    (((bitvector_nat_big idx1  + wordSizeEighth <= bitvector_nat_big idx2) /\
      (bitvector_nat_big idx2  + wordSizeEighth < 2 ^ wordSize)) \/
    (*  |----------------|
          |--|      |--|
          2  2+     1  1+   *)
     ((bitvector_nat_big idx2  + wordSizeEighth <= bitvector_nat_big idx1) /\
      (bitvector_nat_big idx1  + wordSizeEighth < 2 ^ wordSize)) \/
    (*  |----------------|
        -|    |--|      |-
         2+   1  1+     2   *)
     ((bitvector_nat_big idx1  + wordSizeEighth <= bitvector_nat_big idx2) /\
      ((bitvector_nat_big idx2  + wordSizeEighth) mod 2 ^ wordSize <= bitvector_nat_big idx1) /\
      (2 ^ wordSize < bitvector_nat_big idx2  + wordSizeEighth)) \/
    (*  |----------------|
        -|    |--|      |-
         1+   2  2+     1   *)
     ((bitvector_nat_big idx2  + wordSizeEighth <= bitvector_nat_big idx1) /\
      ((bitvector_nat_big idx1  + wordSizeEighth) mod 2 ^ wordSize <= bitvector_nat_big idx2)/\
      (2 ^ wordSize < bitvector_nat_big idx1  + wordSizeEighth))) ->
    Memory_Word_Store_from_Reg
      (Memory_Word_Store_from_Reg m idx1 block)
      idx2 block'
    = Memory_Word_Store_from_Reg
        (Memory_Word_Store_from_Reg m idx2 block')
        idx1 block.
Proof.
  intros.
  unfold Memory_Word_Store_from_Reg, Memory_Word_Load_from_Reg.
  unfold Memory_Word_Store, Memory_Word_Load.
  unfold Memory_Block_Load, Memory_Block_Store.
  rewrite Block_Store_Store_Swap;[reflexivity|assumption].
Qed.

Theorem Memory_Word_Load_from_Reg_const : forall
  (idx : Word)
  (val : Byte),
  Memory_Word_Load_from_Reg (VectorDef.const val _) idx
  = vector_concat (VectorDef.const val _).
Proof.
  intros.
  unfold Memory_Word_Load_from_Reg, Memory_Word_Load, Memory_Block_Load.
  rewrite Block_Load_const.
  rewrite rev_const; reflexivity.
Qed.

End TinyRAMMem.


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

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

Print Assumptions opp.


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

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

Print Assumptions add.


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

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

Print Assumptions mul.


Require Export Pig.SfLib.
Require Export Pig.Schema.

Inductive ty: Set :=
| TUnit : ty
| TFn : schema_ty -> schema_ty -> ty
| TPred : schema_ty -> ty
| TSchema : schema_ty -> ty.

Inductive udf_ty : ty -> Prop :=
| UDFTFn: forall s1 s2: schema_ty,
    udf_ty (TFn s1 s2)
| UDFTPred: forall s,
    udf_ty (TPred s).

Inductive loadable_ty : ty -> Prop :=
| LTSchema: forall s: schema_ty,
    loadable_ty (TSchema s)
| LTUDF: forall UDF: ty,
    udf_ty UDF ->
    loadable_ty UDF.

Definition context := partial_map ty.


Require Import ZArith.
From Bremen.theories.harmony Require Import
  Letter PitchClass Pitch Chord Interval IntervalStructure AbstractChord Note.
From Bremen.theories.rhythm Require Import Duration.
From Bremen.theories.structure Require Import MelodicPart.

Inductive triadName : Type :=
  | majorTriad : pitchClass -> triadName
  | minorTriad : pitchClass -> triadName.

Definition major_structure := -- P1_ -- M3_ -- P5_ .
Definition minor_structure := -- P1_ -- m3_ -- P5_ .

Definition triadNotes (n : triadName) : abstractChord :=
  match n with
  | majorTriad pc => apply_to_pitch_class pc major_structure
  | minorTriad pc => apply_to_pitch_class pc minor_structure
  end.

(*Very restrictive formalization, but should be enough for now.*)
Inductive tensionNote : Type :=
  | T2 | T4 | T6 | T7 .

Inductive quadratonicName : Type :=
  | quad : triadName -> tensionNote -> quadratonicName.

Definition quadratonicNotes (n : quadratonicName) : abstractChord :=
  match n with | quad triad tension =>
    following (triadNotes triad)
      (match tension, triad with
        | T2, majorTriad pc => Interval.apply_to_pitch_class pc (M2_)
        | T4, majorTriad pc => Interval.apply_to_pitch_class pc (P4_)
        | T6, majorTriad pc => Interval.apply_to_pitch_class pc (M6_)
        | T7, majorTriad pc => Interval.apply_to_pitch_class pc (M7_)
        | T2, minorTriad pc => Interval.apply_to_pitch_class pc (M2_)
        | T4, minorTriad pc => Interval.apply_to_pitch_class pc (P4_)
        | T6, minorTriad pc => Interval.apply_to_pitch_class pc (M6_)
        | T7, minorTriad pc => Interval.apply_to_pitch_class pc (M7_)
      end)
  end.

Inductive quadratonicProgression : Type :=
  | first : quadratonicName -> duration -> quadratonicProgression
  | next : quadratonicName -> duration -> quadratonicProgression -> quadratonicProgression.
(*
(*TODO*)
Fixpoint first_quad_assumption (melody : melodic_part) (qn : quadratonicName)
  : option quadratonicName :=

  None.

Fixpoint first_quadratonic_of (melody : melodic_part) : option quadratonicName :=
  match melody with
  | melodic_part_of note =>
    match (pitch_class_of note) with
    | Some pc => Some (quad (majorTriad pc) T2)
    | None => None
    end
  | longer note remaining =>
    match (pitch_class_of note) with
    | Some pc => first_quad_assumption melody (quad (majorTriad pc) T2)
    | None => first_quadratonic_of remaining
    end
  end.

(*TODO*)
Fixpoint quadratonic_progression_of (melody : melodic_part) : quadratonicProgression :=
  match melody with
  | melodic_part_of note => first (quad (majorTriad (C # 0)) T2) (Whole_)
  | longer note remaining => next (quad (majorTriad (C # 0)) T2) (Whole_)
                              (quadratonic_progression_of remaining)
  end.

Eval compute in first_quadratonic_of example_melody1.
*)


Require Import Bool Arith List.
Set Implicit Arguments.
Set Asymmetric Patterns.

(* Inductive tuple (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X). *)

Definition table_T (tuple_T: Type) := list tuple_T.
Definition non_empty {tuple_T: Type} (l: table_T tuple_T) :=
  match l with
   | nil => False
   | h :: t => True
  end.

Fixpoint fold_f {tuple_T aggr_T: Type}
(f : tuple_T->aggr_T->aggr_T) (l : table_T tuple_T) (b : aggr_T) : aggr_T :=
  match l with
  | nil => b
  | h :: t => f h (fold_f f t b)
  end.

Fixpoint filter {tuple_T: Type}
(f : tuple_T -> bool) (l : table_T tuple_T) : table_T tuple_T:=
  match l with
  | nil => nil
  | h :: t => if f h then h :: (filter f t) else (filter f t)
  end.

Lemma length_concat :
forall (X: Type) (t1 t2: table_T X), length (t1 ++ t2) = length t1 + length t2.
Proof.
induction t1.
  + simpl. reflexivity.
  + intros. simpl. apply f_equal. apply IHt1.
Qed.

Lemma helper_le_split :
  forall (a b : nat), a <= S b -> (a <= b \/ a = S b).
Admitted.

Lemma filter_distribute :
forall (tuple_T : Type) (t1 t2 : table_T tuple_T) (g : tuple_T -> bool),
  filter g (t1 ++ t2) = (filter g t1) ++ (filter g t2).
Admitted.

(* INNER JOIN *)
(* for tup1 in table1:
     for tup2 in table2:
        if join_match (tup1 tup2):
          emit (join_f (tup1 tup2))
*)
Fixpoint innerjoin_onetup {tuple_T1 tuple_T2 output_T: Type}
(tuple1 : tuple_T1) (t2 : table_T tuple_T2)
(join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
 : table_T output_T :=
  match t2 with
    | nil => nil
    | h :: t => match join_match tuple1 h with
                  | true => (join_f tuple1 h) :: (innerjoin_onetup tuple1 t join_match join_f )
                  | false => innerjoin_onetup tuple1 t join_match join_f
                end
  end.

Fixpoint innerjoin {tuple_T1 tuple_T2 output_T: Type}
  (t1: table_T tuple_T1) (t2: table_T tuple_T2)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
  : table_T output_T :=
  match t1 with
    | nil => nil
    | h :: t => innerjoin_onetup h t2 join_match join_f ++ innerjoin t t2 join_match join_f
  end.

(* LEFT OUTER JOIN *)
(* for tup1 in table1:
     match = False
     for tup2 in table2:
        if join_match (tup1 tup2):
          emit (join_f (tup1 tup2))
          match = True
     if match = False:
       emit (join_nomatch (tup1))
*)
Fixpoint outerjoin_onetup {tuple_T1 tuple_T2 output_T: Type}
(tuple1 : tuple_T1) (t2 : table_T tuple_T2)
(join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
(join_nomatch : tuple_T1->output_T)
 : table_T output_T :=
  match t2 with
     | nil => join_nomatch tuple1::nil
     | h :: t => match join_match tuple1 h with
                  | true => (join_f tuple1 h) :: (innerjoin_onetup tuple1 t join_match join_f)
                  | false => outerjoin_onetup tuple1 t join_match join_f join_nomatch
                 end
  end.

Fixpoint outerjoin {tuple_T1 tuple_T2 output_T: Type}
  (t1: table_T tuple_T1) (t2: table_T tuple_T2)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (join_nomatch : tuple_T1->output_T)
  : table_T output_T :=
    match t1 with
      | nil => nil
      | h :: t => (outerjoin_onetup h t2 join_match join_f join_nomatch) ++
                    (outerjoin t t2 join_match join_f join_nomatch)
    end.

Lemma table_add_nil :
  forall (tuple_T : Type) (table : table_T tuple_T),
    table++nil = table.
Proof. intros. induction table. simpl. reflexivity.
simpl. rewrite IHtable. reflexivity.
Qed.

Lemma table_append_eq_split:
  forall (tuple_T : Type) (table : table_T tuple_T) (tuple : tuple_T),
    tuple::table = (tuple::nil) ++ table.
Proof. intros. simpl. reflexivity.
Qed.

(*
Lemma outerjoin_equal_maintained_when_switch_order :
  forall (tuple_T1 tuple_T2 output_T: Type)
(tuple1 : tuple_T1) (tuple2 : tuple_T2) (t21 t22 t23 t24 : table_T tuple_T2)
(join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
(join_nomatch : tuple_T1->output_T),
   (outerjoin_onetup tuple1 (t21++t22) join_match join_f join_nomatch
      = outerjoin_onetup tuple1 (t23++t24) join_match join_f join_nomatch) ->
   (outerjoin_onetup tuple1 (t22++t21) join_match join_f join_nomatch
      = outerjoin_onetup tuple1 (t24++t23) join_match join_f join_nomatch).
Proof. intros.
induction t21.
  { rewrite table_add_nil. simpl in H.  }
  { rewrite table_add_nil. rewrite table_add_nil. simpl in H. exact H. }
  {
*)

Lemma outerjoin_small_table_no_match_head :
  forall (tuple_T1 tuple_T2 output_T: Type)
(tuple1 : tuple_T1) (tuple2 : tuple_T2) (t2 : table_T tuple_T2)
(join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
(join_nomatch : tuple_T1->output_T),
  join_match tuple1 tuple2 = false ->
      outerjoin_onetup tuple1 (tuple2::t2) join_match join_f join_nomatch
    = outerjoin_onetup tuple1 t2 join_match join_f join_nomatch.
Proof. intros.
simpl. rewrite H. reflexivity.
Qed.

Lemma outerjoin_small_table_no_match_mid :
  forall (tuple_T1 tuple_T2 output_T: Type)
(tuple1 : tuple_T1) (tuple2 : tuple_T2) (t2 t2': table_T tuple_T2)
(join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
(join_nomatch : tuple_T1->output_T),
  join_match tuple1 tuple2 = false ->
      outerjoin_onetup tuple1 (t2++(tuple2::t2')) join_match join_f join_nomatch
    = outerjoin_onetup tuple1 (t2++t2') join_match join_f join_nomatch.
Admitted.
(*
Proof. intros.
simpl. rewrite H. reflexivity.
Qed.
*)

Lemma innerjoin_distributive :
  forall (tuple_T1 tuple_T2 output_T: Type)
(tuple1 : tuple_T1) (tuple2 : tuple_T2) (t2 t2': table_T tuple_T2)
(join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T),
  innerjoin_onetup tuple1 (t2++t2') join_match join_f
  = (innerjoin_onetup tuple1 t2 join_match join_f)++(innerjoin_onetup tuple1 t2' join_match join_f).
Proof. intros.
induction t2. simpl. reflexivity.
simpl. case (join_match tuple1 a). rewrite IHt2. reflexivity.
rewrite IHt2.
   reflexivity.
Qed.

Lemma filter_add_redundant_head :
  forall (tuple_T2 : Type) (g: tuple_T2 -> bool) (tuple: tuple_T2) (table: table_T tuple_T2),
  (g tuple = false) -> (filter g table = filter g (tuple::table)).
Proof. intros.
simpl. rewrite H. reflexivity.
Qed.

Lemma filter_add_redundant_mid :
  forall (tuple_T2 : Type) (g: tuple_T2 -> bool) (t1 t2: tuple_T2) (table: table_T tuple_T2),
  (g t2 = false) -> (filter g (t1::table) = filter g (t1::(t2::table))).
Proof. intros.
simpl. rewrite H. reflexivity.
Qed.

Definition innerjoin_predicate_pushdown {tuple_T1 tuple_T2 output_T: Type}
    (len:nat)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (f : output_T->bool) (g2 : tuple_T2->bool) :=
      forall (tuple1: tuple_T1) (table2: table_T tuple_T2),
       (length table2 <= len) ->
          (filter f (innerjoin_onetup tuple1 table2 join_match join_f) =
           innerjoin_onetup tuple1 (filter g2 table2) join_match join_f
          ).

Theorem innerjoin_predicate_pushdown_smallmodel :
  forall (tuple_T1 tuple_T2 output_T : Type) (len: nat)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (join_nomatch : tuple_T1->output_T)
    (f : output_T->bool) (g2 : tuple_T2->bool),
innerjoin_predicate_pushdown 1 join_match join_f f g2 ->
innerjoin_predicate_pushdown len join_match join_f f g2.
Proof. intros. destruct len.
  {  unfold innerjoin_predicate_pushdown. intros.
     destruct table2. simpl. reflexivity. simpl in H0. apply Nat.nle_succ_0 in H0. contradiction. }
  { unfold innerjoin_predicate_pushdown. intros.
     induction table2. simpl. reflexivity.
     rewrite table_append_eq_split with (tuple := a).
     rewrite filter_distribute.
     rewrite innerjoin_distributive.
     simpl in H0. apply Peano.le_S_n in H0. apply Nat.le_le_succ_r in H0.
     assert (Htable2_simpl: filter f (innerjoin_onetup tuple1 table2 join_match join_f) =
           innerjoin_onetup tuple1 (filter g2 table2) join_match join_f).
        { apply IHtable2. exact H0. }
     rewrite filter_distribute. rewrite Htable2_simpl.
     rewrite innerjoin_distributive.
     assert (Htable2_initcase: filter f (innerjoin_onetup tuple1 (a :: nil) join_match join_f)
        = innerjoin_onetup tuple1 (filter g2 (a :: nil)) join_match join_f).
        { apply H. simpl. auto. }
     rewrite Htable2_initcase.
     reflexivity.
     auto. auto.
  }
Qed.

(* f(txu) = false -> f(t x ?) = nil *)
Definition assumption1 {tuple_T1 tuple_T2 output_T: Type}
  (len: nat)
  (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (f : output_T->bool) :=
      forall (tuple1: tuple_T1) (tuple2: tuple_T2) (table2: table_T tuple_T2),
        (length table2 <= len /\
         join_match tuple1 tuple2 = true /\ f (join_f tuple1 tuple2) = false) ->
          filter f (innerjoin_onetup tuple1 table2 join_match join_f) = nil.

Theorem assumption1_small_model :
  forall (tuple_T1 tuple_T2 output_T : Type) (len: nat)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (f : output_T->bool) ,
    assumption1 1 join_match join_f f -> assumption1 len join_match join_f f.
Proof. intros.
destruct len.
 { unfold assumption1. intros. destruct H0. destruct H1.
   destruct table2. simpl. reflexivity. simpl in H0. apply Nat.nle_succ_0 in H0. contradiction. }
induction len. exact H.
  unfold assumption1. intros.
  destruct H0. destruct H1.
  apply helper_le_split in H0.
  destruct H0. unfold assumption1 in H. apply IHlen with (tuple2:=tuple2).
  split. exact H0. split. exact H1. exact H2.
  destruct table2. simpl. reflexivity.
  unfold assumption1 in IHlen.
  assert (Htemp : filter f (innerjoin_onetup tuple1 table2 join_match join_f) = nil).
   { apply IHlen with (tuple2:=tuple2). split. simpl in H0. apply Nat.succ_inj in H0.
     rewrite H0. auto. split. auto. auto. }
  assert (Htemp2 : filter f (innerjoin_onetup tuple1 (t::nil) join_match join_f) = nil).
    { apply IHlen with (tuple2:=tuple2). simpl. split. apply Peano.le_n_S. apply Nat.le_0_l.
      split. auto. auto. }
  rewrite table_append_eq_split. rewrite innerjoin_distributive.
  rewrite filter_distribute. rewrite Htemp. rewrite Htemp2. auto. auto.
Qed.

(* f(txu) = true -> g2(u) = true *)
Definition assumption2 {tuple_T1 tuple_T2 output_T: Type}
  (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (f : output_T->bool) (g2 : tuple_T2->bool) :=
      forall (tuple1: tuple_T1) (tuple2: tuple_T2) (table2: table_T tuple_T2),
        (join_match tuple1 tuple2 = true /\ f (join_f tuple1 tuple2) = true) ->
          g2 tuple2 = true.

Definition outerjoin_predicate_pushdown {tuple_T1 tuple_T2 output_T: Type}
    (len:nat)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (join_nomatch : tuple_T1->output_T)
    (f : output_T->bool) (g1 : tuple_T1->bool) (g2 : tuple_T2->bool) :=
      forall (tuple1: tuple_T1) (table2: table_T tuple_T2),
       (length table2 <= len /\ non_empty table2) ->
          (filter f (outerjoin_onetup tuple1 table2 join_match join_f join_nomatch) =
            match g1 tuple1 with
              | true => outerjoin_onetup tuple1 (filter g2 table2) join_match join_f join_nomatch
              | false => nil
            end
          ).

Theorem outerjoin_remove_assumption1 :
forall (tuple_T1 tuple_T2 output_T : Type)
  (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (join_nomatch : tuple_T1->output_T)
    (f : output_T->bool) (g1 : tuple_T1->bool) (g2 : tuple_T2->bool),
(outerjoin_predicate_pushdown 1 join_match join_f join_nomatch f g1 g2) ->
assumption1 1 join_match join_f f .
Proof. intros.
unfold outerjoin_predicate_pushdown in H.
unfold assumption1. intros.
destruct H0 as [H0 H1]. destruct H1 as [H1 H2].
destruct table2. simpl. reflexivity.
destruct table2. simpl. (* length table2 = 1 *)
assert(Hg1t_false : g1 tuple1 = false).
{
  assert(Hrewrite_f : filter f ((join_f tuple1 tuple2)::nil)
  = filter f (outerjoin_onetup tuple1 (tuple2::nil) join_match join_f join_nomatch)).
    { simpl. rewrite H1. rewrite H2. simpl. rewrite H2. reflexivity. }
  assert(Hrewrite_g : filter f (outerjoin_onetup tuple1 (tuple2::nil) join_match join_f join_nomatch)
  = if g1 tuple1 then outerjoin_onetup tuple1 (filter g2 (tuple2::nil)) join_match join_f join_nomatch
      else nil).
    { apply H. split. simpl. auto. simpl. auto. }
  assert(Hg_nil: (if g1 tuple1 then outerjoin_onetup tuple1 (filter g2 (tuple2::nil)) join_match join_f join_nomatch
      else nil) = nil).
    { rewrite <- Hrewrite_g. rewrite <- Hrewrite_f. simpl. rewrite H2. reflexivity. }
  destruct (g1 tuple1) eqn:Hassump.
  simpl in Hg_nil.
  destruct (g2 tuple2). simpl in Hg_nil. rewrite H1 in Hg_nil. discriminate.
  simpl in Hg_nil. discriminate.
  auto.
}
assert(Htuple2_g_nil : (if g1 tuple1 then outerjoin_onetup tuple1 (filter g2 (t::nil)) join_match join_f join_nomatch
 else nil) = nil).
  { rewrite Hg1t_false. reflexivity. }
assert(Htuple2_outer_nil : filter f (outerjoin_onetup tuple1 (t::nil) join_match join_f join_nomatch)
 = nil).
  { rewrite <- Htuple2_g_nil. apply H. split. simpl. auto. simpl. auto.  }
destruct (join_match tuple1 t) eqn:Ht_match.
unfold outerjoin_onetup in Htuple2_outer_nil. rewrite Ht_match in Htuple2_outer_nil.
simpl in Htuple2_outer_nil.
destruct (f (join_f tuple1 t)) eqn:Hjoint_pass_filter.
rewrite Htuple2_outer_nil. simpl. reflexivity.
simpl. rewrite Hjoint_pass_filter. reflexivity. simpl. reflexivity.
simpl in H0. apply Peano.le_S_n in H0. apply Nat.nle_succ_0 in H0. contradiction.
Qed.

(*
  txU
  case tx(u::U):
    if t match U and t match u:
        tx(u::U)=txu++txU
    if t don't match U and t match u:
        f(tx(u::U))=f(tx(u::(u1::U'))=tx(g(u)::g(U'))=tx(g(u::U'))=tx(g(u::(u1::U'))
    if t don't match u:
        f(tx(u::U))=f(tx(U))=tx(g(U))=tx(g(u::U'))
*)
Theorem outerjoin_pushdown_small_model :
forall (tuple_T1 tuple_T2 output_T : Type) (len: nat)
    (join_match : tuple_T1->tuple_T2->bool) (join_f : tuple_T1->tuple_T2->output_T)
    (join_nomatch : tuple_T1->output_T)
    (f : output_T->bool) (g1 : tuple_T1->bool) (g2 : tuple_T2->bool),
(innerjoin_predicate_pushdown 1 join_match join_f f g2 /\
assumption2 join_match join_f f g2 /\
outerjoin_predicate_pushdown 1 join_match join_f join_nomatch f g1 g2) ->
outerjoin_predicate_pushdown len join_match join_f join_nomatch f g1 g2.
Proof. intros.
destruct len.
unfold outerjoin_predicate_pushdown. intros.
  { destruct H0 as [H0 H1]. destruct table2. simpl in H1. contradiction. simpl in H0. apply Nat.nle_succ_0 in H0. contradiction. }
induction len. destruct H as [Hinnerjoin H]. destruct H as [Hassumption2 H].
exact H.
unfold outerjoin_predicate_pushdown. intros.
destruct H0 as [H0 H1].
apply helper_le_split in H0.
destruct H0.
  { apply IHlen. split. exact H0. exact H1. }
destruct table2 as [|u U].
  { simpl in H0. discriminate. }
  { destruct H as [Hinnerjoin H]. destruct H as [Hassumption2 H].
    simpl.
    destruct (join_match tuple1 u) eqn:H4.
    case (innerjoin_onetup tuple1 U join_match join_f) eqn:H5.
    { (* t match u and t does not match U *)
      destruct U as [|u1 U'].
        { assert (Hrewrite_f : filter f (join_f tuple1 u :: nil)
          = filter f (outerjoin_onetup tuple1 (u::nil) join_match join_f join_nomatch)).
            { simpl. rewrite H4. reflexivity. }
          rewrite Hrewrite_f.
          assert (Hrewrite_g : outerjoin_onetup tuple1 (if g2 u then u :: filter g2 nil else filter g2 nil)
  join_match join_f join_nomatch = outerjoin_onetup tuple1 (filter g2 (u::nil)) join_match join_f join_nomatch).
            { simpl. reflexivity. }
          rewrite Hrewrite_g.
          apply H. split. simpl. auto. simpl. auto.
        }
        {
          assert (Hu1_nomatch : join_match tuple1 u1 = false).
            { simpl in H5.  destruct (join_match tuple1 u1) eqn:H6 in H5.
              discriminate. auto.
            }
          assert (Hrewrite_g_1: outerjoin_onetup tuple1
  (if g2 u then u :: filter g2 (u1 :: U') else filter g2 (u1 :: U')) join_match
  join_f join_nomatch = outerjoin_onetup tuple1 (filter g2 ((u::nil)++(u1::U'))) join_match join_f join_nomatch).
            { simpl. reflexivity. }
          rewrite Hrewrite_g_1.
          assert (Hrewrite_g_2 : outerjoin_onetup tuple1 (filter g2 ((u::nil)++(u1::U'))) join_match join_f join_nomatch
              = outerjoin_onetup tuple1 (filter g2 (u::U')) join_match join_f join_nomatch).
             { rewrite table_append_eq_split with (tuple:=u) (table:=U').
               rewrite filter_distribute. rewrite filter_distribute.
               simpl. destruct (g2 u1) eqn:H6.
              apply outerjoin_small_table_no_match_mid. exact Hu1_nomatch. reflexivity.
             }
          rewrite Hrewrite_g_2.
          assert (Hrewrite_f : filter f (join_f tuple1 u :: nil) =
              filter f (outerjoin_onetup tuple1 (u::U') join_match join_f join_nomatch)).
             {
              simpl. rewrite H4. simpl.
              rewrite table_append_eq_split in H5.
              rewrite innerjoin_distributive in H5.
              apply app_eq_nil in H5.
              destruct H5 as [H51 H52].
              rewrite H52.
              simpl.  reflexivity. auto.
             }
          rewrite Hrewrite_f.
          apply IHlen.
          split. simpl. apply Peano.le_n_S. simpl in H0. apply Nat.succ_inj in H0. apply Nat.succ_inj in H0.
          rewrite H0. auto. simpl. auto.
        }
    }

    { (* t match u and t match U *)
      rewrite table_append_eq_split with (tuple:=(join_f tuple1 u)) (table:=o::t).
      rewrite filter_distribute.
      destruct (filter f (join_f tuple1 u :: nil)) eqn:Ht_join_u.
        { (* f(txu)=nil -> g1(t)=nil -> f(tx(u::U'))=f(tx(U'))=tx(g(U'))=nil++tx(g(u+U'))=g1(t)x *)
          assert (Htemp1: g1 tuple1 = false).
            { assert (Htemp2 : filter f (join_f tuple1 u :: nil) =
          filter f (outerjoin_onetup tuple1 (u::nil) join_match join_f join_nomatch)).
                { simpl. rewrite H4. simpl. reflexivity. }
              rewrite Ht_join_u in Htemp2.
              assert (Htemp3: filter f (outerjoin_onetup tuple1 (u :: nil) join_match join_f join_nomatch)
               = (match g1 tuple1 with
              | true => outerjoin_onetup tuple1 (filter g2 (u::nil)) join_match join_f join_nomatch
              | false => nil
            end )).
                { unfold outerjoin_predicate_pushdown in H. apply H. simpl. split. auto. auto. }
               destruct (g1 tuple1) eqn:Hg1_tuple1.
                { rewrite <- Htemp2 in Htemp3. simpl in Htemp3.
                  destruct (g2 u) eqn:Hg2_u. simpl in Htemp3. rewrite H4 in Htemp3. discriminate.
                  simpl in Htemp3. discriminate.
                }
               auto.
            }
          rewrite <- H5.
          assert (Hassumption1_general : assumption1 (S len) join_match join_f f).
            { assert (Hassumption1: assumption1 1 join_match join_f f).
                { apply outerjoin_remove_assumption1 with (join_nomatch:=join_nomatch) (g1:=g1) (g2:=g2). exact H. }
              apply assumption1_small_model. exact Hassumption1. }
          assert (Hfilter_none: filter f (innerjoin_onetup tuple1 U join_match join_f) = nil).
            { unfold assumption1 in Hassumption1_general.
              apply Hassumption1_general with (tuple2:=u).
              split. simpl in H0. apply Nat.succ_inj in H0. rewrite H0. auto.
              split. auto. auto. simpl in Ht_join_u.
              destruct (f (join_f tuple1 u)) eqn:Htemp. discriminate. auto.
            }
          rewrite Hfilter_none. rewrite Htemp1. simpl. reflexivity.
        }
        { (* f(txu)=true -> g(u) = true*)
          assert (Hg1_true : g1 tuple1 = true).
            { assert (Htemp2 : filter f (join_f tuple1 u :: nil) =
          filter f (outerjoin_onetup tuple1 (u::nil) join_match join_f join_nomatch)).
                { simpl. rewrite H4. simpl. reflexivity. }
              rewrite Ht_join_u in Htemp2.
              assert (Htemp3: filter f (outerjoin_onetup tuple1 (u :: nil) join_match join_f join_nomatch)
               = (match g1 tuple1 with
              | true => outerjoin_onetup tuple1 (filter g2 (u::nil)) join_match join_f join_nomatch
              | false => nil
            end )).
                { unfold outerjoin_predicate_pushdown in H. apply H. simpl. split. auto. auto. }
              destruct (g1 tuple1) eqn:Hg1_tuple1.
                { auto. } { rewrite <- Htemp2 in Htemp3. discriminate. }
            }
          assert (Hg2_true : g2 u = true).
            { unfold assumption2 in Hassumption2. apply Hassumption2 with (tuple1:=tuple1).
              auto. split. auto. simpl in Ht_join_u.
              destruct (f (join_f tuple1 u)) eqn:Htemp. auto. discriminate.
            }
          rewrite Hg1_true. rewrite Hg2_true. rewrite <- H5. rewrite <- Ht_join_u.
          rewrite <- filter_distribute.
          assert (Hrewrite_f : (join_f tuple1 u :: nil) = innerjoin_onetup tuple1 (u::nil) join_match join_f).
            { simpl. rewrite H4. reflexivity. }
          rewrite Hrewrite_f.
          rewrite <- innerjoin_distributive.
          unfold outerjoin_onetup.
          rewrite H4.
          assert (Hrewrite_g : join_f tuple1 u :: innerjoin_onetup tuple1 (filter g2 U) join_match join_f =
              innerjoin_onetup tuple1 (filter g2 ((u::nil) ++ U)) join_match join_f).
            { simpl. rewrite Hg2_true. simpl. rewrite H4. reflexivity. }
          rewrite Hrewrite_g.
          assert (Hinnerjoin_general : innerjoin_predicate_pushdown (S (S len)) join_match join_f f g2).
            {  apply innerjoin_predicate_pushdown_smallmodel. auto. exact Hinnerjoin. }
          apply Hinnerjoin_general. simpl. apply Peano.le_n_S. simpl in H0.  apply Nat.succ_inj in H0. rewrite H0. auto. auto.

        }
    }

    { (* t does not match u *)
      destruct (g2 u) eqn: Hg2u_case.
      simpl. rewrite H4. apply IHlen. split. simpl in H0. apply Nat.succ_inj in H0.
      rewrite H0. auto. destruct U. simpl in H0. apply Nat.succ_inj in H0. discriminate.
      simpl. auto. apply IHlen. split. simpl in H0. apply Nat.succ_inj in H0. rewrite H0.
      auto. destruct U. simpl in H0. apply Nat.succ_inj in H0. discriminate. simpl. auto.
    }
}
Qed.

(* Extended join pattern 1 *)
(* for tup1 in table1:
      Op(table2, tup1) [Op: tuple_T1->table_T(tuple_T2)->output_T
*)

Fixpoint nested_loop_1 {tuple_T1 tuple_T2 output_T: Type}
  (t1: table_T tuple_T1) (t2: table_T tuple_T2)
    (Op: tuple_T1->(table_T tuple_T2)->output_T)
  : table_T output_T :=
    match t1 with
      | nil => nil
      | h :: t => (Op h t2) :: (nested_loop_1 t t2 Op)
    end.

Definition nested_loop_1_pred_pushdown {tuple_T1 tuple_T2 output_T: Type}
  (len: nat) (Op: tuple_T1->(table_T tuple_T2)->output_T)
  (f: output_T->bool) (g1: tuple_T1->bool) (g2: tuple_T2->bool) :=
  forall (t1: table_T tuple_T1) (t2: table_T tuple_T2),
    (length t1 <= len /\ length t2 <= len) ->
      (filter f (nested_loop_1 t1 t2 Op)) =
      (nested_loop_1 (filter g1 t1) (filter g2 t2) Op).

Definition nested_loop_1_pred_pushdown_sub {tuple_T1 tuple_T2 output_T: Type}
  (len: nat) (Op: tuple_T1->(table_T tuple_T2)->output_T)
  (f: output_T->bool) (g1: tuple_T1->bool) (g2: tuple_T2->bool) :=
  forall (tup1: tuple_T1) (t2: table_T tuple_T2),
    (length t2 <= len) ->
      (filter f (nested_loop_1 (tup1::nil) t2 Op)) =
      (nested_loop_1 (filter g1 (tup1::nil)) (filter g2 t2) Op).

Definition Op_assumption_true {tuple_T1 tuple_T2 output_T: Type}
(Op: tuple_T1->(table_T tuple_T2)->output_T)
  (f: output_T->bool) (g1: tuple_T1->bool) (g2: tuple_T2->bool) :=
  forall (tup1: tuple_T1) (t2: table_T tuple_T2),
    (g1 tup1 = true) -> (match (f (Op tup1 t2)) with
                           | true => (Op tup1 t2)::nil
                           | false => nil
                         end) = (Op tup1 (filter g2 t2))::nil.

Definition Op_assumption_false {tuple_T1 tuple_T2 output_T: Type}
(Op: tuple_T1->(table_T tuple_T2)->output_T)
  (f: output_T->bool) (g1: tuple_T1->bool) (g2: tuple_T2->bool) :=
  forall (tup1: tuple_T1) (t2: table_T tuple_T2),
    (g1 tup1 = false) -> f (Op tup1 t2) = false.

Theorem nested_loop_1_pred_pushdown_sub_small_model :
forall (tuple_T1 tuple_T2 output_T: Type) (len: nat)
(Op: tuple_T1->(table_T tuple_T2)->output_T)
  (f: output_T->bool) (g1: tuple_T1->bool) (g2: tuple_T2->bool),
(Op_assumption_true Op f g1 g2 /\ Op_assumption_false Op f g1 g2 /\
nested_loop_1_pred_pushdown_sub 1 Op f g1 g2)
-> nested_loop_1_pred_pushdown_sub len Op f g1 g2.
Proof. intros.
destruct len.
  { unfold nested_loop_1_pred_pushdown_sub. intros.
  apply H. destruct t2. simpl. auto. simpl in H0. apply Nat.nle_succ_0 in H0. contradiction.
  }
induction len.
destruct H as [Hassump_true H].
destruct H as [Hassump_false H]. exact H.
destruct H as [Hassump_true H].
destruct H as [Hassump_false H].
unfold nested_loop_1_pred_pushdown_sub. intros.
simpl.
apply helper_le_split in H0.
destruct H0. apply IHlen. exact H0.
unfold nested_loop_1.
destruct (g1 tup1) eqn:Hg1. simpl.
unfold Op_assumption_true in Hassump_true. apply Hassump_true. exact Hg1.
unfold Op_assumption_false in Hassump_false.
assert (f (Op tup1 t2) = false). {  apply Hassump_false. exact Hg1. }
rewrite H1. reflexivity.
Qed.

(* size=1 correct; Op true for any tup1 and t2 *)

(* subset :  *)

(* Generalized OUTER JOIN *)
(*
    for tup1 in table1:
      state = init(tup1)
      for tup2 in table2:
         state = fold (state tup1 tup2)
         if output_b (state tup1 tup2):
            emit (join_f (state tup1 tup2)
      if output_state_b (state)
        emit (ouptut_state_f (state))

*)

Fixpoint outerjoin_onetup {tuple_T1 tuple_T2 state_T output_T: Type}
(state_init : tuple_T1->state_T)
(fold: state_T->tuple_T1->tuple_T2->state_T)
(output_b: state_T->tuple_T1->tuple_T2->bool)
(join_f: state_T->tuple_T1->tuple_T2->output_T)
(output_state_b: state_T->bool)
(output_state_f: state_T->output_T)
(tuple1 : tuple_T1) (t2 : table_T tuple_T2) : table_T state_T*output_T
  match t2 with
    | nil => state_init tuple1
    | h :: t => match
  end.

Fixpoint outerjoin {tuple_T1 tuple_T2 output_T: Type}

    (t1: table_T tuple_T1) (t2: table_T tuple_T2) : table_T output_T :=
  match t1 with
    | nil => nil
    | h :: t =>


(** printing \2/ $\cup$ #∪# *)
(** printing <2= $\subseteq$ #⊆# *)
(** printing forall $\forall$ #∀# *)
(** printing -> $\rightarrow$ #→# *)
(** printing /\ $\land$ #∧# *)

Require Import ZArith List String.
Require Import Paco.paco.
Import ListNotations.

Set Implicit Arguments.
Set Contextual Implicit.

(** * A Mixed Induction-Coinduction Example

    Written by Steve Zdancewic.
*)

CoInductive stream (A:Type) :=
| snil : stream A
| scons : A -> stream A -> stream A
.

Arguments scons {_} _ _.

Definition id_match_stream {A} (s:stream A) : stream A :=
  match s with
  | snil => snil
  | scons x t => scons x t
  end.

Lemma id_stream_eq : forall A (s:stream A), s = id_match_stream s.
Proof.
  intros.
  destruct s; auto.
Qed.

(* A more relaxed notion of equivalence where the 0's can be inserted finitely often in either
   stream. *)
Inductive seq_step (seq : stream nat -> stream nat -> Prop) : stream nat -> stream nat -> Prop :=
| seq_nil  : seq_step seq snil snil
| seq_cons : forall s1 s2 n (R : seq s1 s2), seq_step seq (scons n s1) (scons n s2)
| seq_cons_z_l : forall s1 s2, seq_step seq s1 s2 -> seq_step seq (scons 0 s1) s2
| seq_cons_z_r : forall s1 s2, seq_step seq s1 s2 -> seq_step seq s1 (scons 0 s2)
.
#[export] Hint Constructors seq_step : core.

Lemma seq_step_mono : monotone2 seq_step.
Proof.
  unfold monotone2. intros x0 x1 r r' IN LE.
  induction IN; eauto.
Qed.
#[export] Hint Resolve seq_step_mono : paco.

Definition seq (s t : stream nat) := paco2 seq_step bot2 s t .
#[export] Hint Unfold seq : core.

Lemma seq_step_refl : forall (R:stream nat -> stream nat -> Prop),
    (forall d, R d d) -> forall d, seq_step R d d.
Proof.
  intros.
  destruct d; constructor; auto.
Qed.

Lemma seq_refl : forall s, seq s s.
Proof.
  pcofix CIH.
  intros s.
  pfold.
  destruct s; auto.
Qed.

Lemma seq_symm : forall s1 s2, seq s1 s2 -> seq s2 s1.
Proof.
  pcofix CIH.
  intros s1 s2 H.
  pfold.
  punfold H.
  induction H; try constructor; auto.
  pclearbot. right. apply CIH. punfold R.
Qed.

Require Import Program Classical.

Inductive zeros_star (P: stream nat -> Prop) : stream nat -> Prop :=
| zs_base t (BASE: P t): zeros_star P t
| zs_step t (LZ: zeros_star P t): zeros_star P (scons 0 t)
.
#[export] Hint Constructors zeros_star : core.

Lemma zeros_star_mono : monotone1 zeros_star.
Proof.
  red. intros. induction IN; eauto.
Qed.
#[export] Hint Resolve zeros_star_mono : core.

Inductive zeros_one (P: stream nat -> Prop) : stream nat -> Prop :=
| zo_step t (BASE: P t): zeros_one P (scons 0 t)
.
#[export] Hint Constructors zeros_one : core.

Lemma zeros_one_mono : monotone1 zeros_one.
Proof.
  pmonauto.
Qed.
#[export] Hint Resolve zeros_one_mono : paco.

Definition infzeros := paco1 zeros_one bot1.
#[export] Hint Unfold infzeros : core.

Inductive nonzero: stream nat -> Prop :=
| nz_nil: nonzero snil
| nz_cons n s (NZ: n <> 0): nonzero (scons n s)
.
#[export] Hint Constructors nonzero : core.

Inductive gseq_cons_or_nil (gseq: stream nat -> stream nat -> Prop) : stream nat -> stream nat -> Prop :=
| gseq_nil : gseq_cons_or_nil gseq snil snil
| gseq_cons s1 s2 n (R: gseq s1 s2) (NZ: n <> 0) : gseq_cons_or_nil gseq (scons n s1) (scons n s2)
.
#[export] Hint Constructors gseq_cons_or_nil : core.

Inductive gseq_step (gseq: stream nat -> stream nat -> Prop) : stream nat -> stream nat -> Prop :=
| gseq_inf s1 s2 (IZ1: infzeros s1) (IZ2: infzeros s2) : gseq_step gseq s1 s2
| gseq_fin s1 s2 t1 t2
     (ZS1: zeros_star (fun t => t = s1) t1)
     (ZS2: zeros_star (fun t => t = s2) t2)
     (R: gseq_cons_or_nil gseq s1 s2)
  : gseq_step gseq t1 t2
.
#[export] Hint Constructors gseq_step : core.

Lemma gseq_step_mono : monotone2 gseq_step.
Proof.
  unfold monotone2. intros.
  induction IN; eauto.
  eapply gseq_fin; eauto.
  destruct R; eauto.
Qed.
#[export] Hint Resolve gseq_step_mono : paco.

Definition gseq (s t : stream nat) := paco2 gseq_step bot2 s t .
#[export] Hint Unfold gseq : core.

Lemma nonzero_not_infzeros: forall s
    (ZST: zeros_star nonzero s)
    (INF: infzeros s),
  False.
Proof.
  intros. revert INF. induction ZST.
  - intro INF. punfold INF. dependent destruction INF.
    dependent destruction BASE. intuition.
  - intro INF. apply IHZST.
    punfold INF. dependent destruction INF. pclearbot. eauto.
Qed.

Lemma infzeros_or_finzeros: forall s,
  infzeros s \/ zeros_star nonzero s.
Proof.
  intros. destruct (classic (zeros_star nonzero s)); eauto.
  left. revert s H. pcofix CIH.
  intros. destruct s.
  - exfalso. eauto.
  - destruct n; [|exfalso; eauto].
    pfold. econstructor. right. eauto.
Qed.

Lemma seq_infzeros_imply: forall s t
  (R: seq s t) (IZ: infzeros s), infzeros t.
Proof.
  pcofix CIH. intros.
  punfold R. revert IZ. induction R; intros.
  - eapply paco1_mon. eauto. intros. inversion PR.
  - pfold. punfold IZ. dependent destruction IZ. pclearbot. eauto.
  - punfold IZ. dependent destruction IZ. pclearbot. eauto.
  - pfold. eauto.
Qed.

Lemma seq_zeros_star_imply: forall s t
  (R: seq s t) (IZ: zeros_star nonzero s), zeros_star nonzero t.
Proof.
  intros. revert t R. induction IZ; intros.
  - punfold R. induction R; pclearbot; eauto.
    + inversion BASE. eauto.
    + inversion BASE. intuition.
  - punfold R. remember(scons 0 t). generalize dependent t.
    induction R; intros; pclearbot; dependent destruction Heqs; eauto.
Qed.

Lemma seq_infzeros_or_finzeros: forall s t
    (R: seq s t),
  (infzeros s /\ infzeros t) \/
  (zeros_star nonzero s /\ zeros_star nonzero t).
Proof.
  intros. destruct (@infzeros_or_finzeros s).
  - eauto using seq_infzeros_imply.
  - eauto using seq_zeros_star_imply.
Qed.

Lemma seq_zero_l: forall s t
    (EQ : seq (scons 0 s) t),
  seq s t.
Proof.
  intros. punfold EQ. pfold.
  remember (scons 0 s). generalize dependent s.
  induction EQ; intros; dependent destruction Heqs0; pclearbot; eauto.
  punfold R.
Qed.

Lemma seq_zero_r: forall s t
    (EQ : seq s (scons 0 t)),
  seq s t.
Proof.
  intros. punfold EQ. pfold.
  remember (scons 0 t). generalize dependent t.
  induction EQ; intros; dependent destruction Heqs0; pclearbot; eauto.
  punfold R.
Qed.

Lemma zero_gseq_l: forall r s t
    (R : paco2 gseq_step r s t),
  paco2 gseq_step r (scons 0 s) t.
Proof.
  intros. punfold R. pfold. destruct R; eauto.
  econstructor; eauto. pfold. eauto.
Qed.

Lemma zero_gseq_r: forall r s t
    (R : paco2 gseq_step r s t),
  paco2 gseq_step r s (scons 0 t).
Proof.
  intros. punfold R. pfold. destruct R; eauto.
  econstructor; eauto. pfold. eauto.
Qed.

Lemma seq_implies_gseq: forall s t
  (R: seq s t), gseq s t.
Proof.
  pcofix CIH.
  intros. destruct (seq_infzeros_or_finzeros R) as [[]|[]]; eauto.
  induction H.
  - induction H0.
    + pfold. punfold R. dependent destruction R; pclearbot; eauto.
      * dependent destruction BASE. eauto 10.
      * dependent destruction BASE. intuition.
      * dependent destruction BASE0. intuition.
    + eauto using seq_zero_r, zero_gseq_r.
  - eauto using seq_zero_l, zero_gseq_l.
Qed.

Lemma gseq_implies_seq: forall s t
  (R: gseq s t), seq s t.
Proof.
  pcofix CIH; intros.
  punfold R. destruct R.
  - punfold IZ1. punfold IZ2.
    dependent destruction IZ1. dependent destruction IZ2. pclearbot.
    pfold. econstructor. right. eauto.
  - induction ZS1; subst.
    + induction ZS2; subst.
      * pfold. dependent destruction R; pclearbot; eauto.
      * pfold. punfold IHZS2.
    + pfold. punfold IHZS1.
Qed.

Lemma gseq_cons_or_nil_nonzero_l: forall r s t
    (R : gseq_cons_or_nil r s t),
  nonzero s.
Proof. intros; destruct R; eauto. Qed.

Lemma gseq_cons_or_nil_nonzero_r: forall r s t
    (R : gseq_cons_or_nil r s t),
  nonzero t.
Proof. intros; destruct R; eauto. Qed.

Lemma zeros_star_nonzero_uniq: forall s1 s2 t
    (ZS1: zeros_star (fun s => s = s1) t)
    (ZS2: zeros_star (fun s => s = s2) t)
    (NZ1: nonzero s1)
    (NZ2: nonzero s2),
  s1 = s2.
Proof.
  intros s1 s2 t ZS1. revert s2.
  induction ZS1; subst; intros.
  - induction ZS2; subst; eauto.
    inversion NZ1. intuition.
  - dependent destruction ZS2; eauto.
    inversion NZ2. intuition.
Qed.

Lemma gseq_trans : forall d1 d2 d3
  (EQL: gseq d1 d2) (EQR: gseq d2 d3), gseq d1 d3.
Proof.
  pcofix CIH; intros.
  punfold EQL. punfold EQR. destruct EQL, EQR; eauto.
  - exfalso. eapply nonzero_not_infzeros, IZ2.
    eapply zeros_star_mono; eauto.
    simpl. intros. subst. destruct R; eauto.
  - exfalso. eapply nonzero_not_infzeros, IZ1.
    eapply zeros_star_mono; eauto.
    simpl. intros. subst. destruct R; eauto.
  - eapply zeros_star_nonzero_uniq in ZS2;
    eauto using gseq_cons_or_nil_nonzero_l, gseq_cons_or_nil_nonzero_r.
    subst. pfold. econstructor 2; eauto.
    destruct R; dependent destruction R0; pclearbot; eauto.
Qed.

Lemma seq_trans : forall d1 d2 d3
  (EQL: seq d1 d2) (EQR: seq d2 d3), seq d1 d3.
Proof.
  eauto using gseq_trans, seq_implies_gseq, gseq_implies_seq.
Qed.


Require Import Coq.Setoids.Setoid.
Require Import VST.msl.Extensionality.

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

Copied From Coq.Logic.JMeq.

No longer involving JMeq_eq, which is potentially inconsistenty with homotopy
type theory.

TODO: let reflexivity, symmetry and transitivity work again.

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

Definition JMeq {A:Type} (x:A) {B:Type} (y: B): Prop :=
  {H: @eq Type A B | @eq_rect Type A (fun T: Type => T) x B H = y}.

Lemma JMeq_refl: forall {A: Type} (x: A), JMeq x x.
Proof.
  intros.
  exists eq_refl.
  rewrite <- eq_rect_eq.
  auto.
Qed.
Hint Resolve JMeq_refl : core.

Lemma JMeq_sym : forall {A: Type} {B:Type} {x:A} {y:B}, JMeq x y -> JMeq y x.
Proof.
  intros.
  destruct H as [?H ?H].
  exists (eq_sym H).
  rewrite <- H0.
  destruct H.
  simpl.
  apply eq_refl.
Qed.
Hint Immediate JMeq_sym : core.

Lemma JMeq_trans :
 forall {A: Type} {B: Type} {C:Type} {x:A} {y:B} {z:C}, JMeq x y -> JMeq y z -> JMeq x z.
Proof.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  exists (eq_trans H H0).
  destruct H, H0.
  rewrite <- H2, <- H1.
  reflexivity.
Qed.

Lemma JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y.
Proof.
  intros.
  destruct H.
  rewrite <- eq_rect_eq in e.
  exact e.
Qed.

Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'.
inversion H'.
subst.
 case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_congr :
 forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y.
Proof.
intros A x B f y H; case JMeq_eq with (1 := H); trivial.
Qed.

(** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *)

Require Import Coq.Logic.Eqdep.

Lemma JMeq_eq_dep_id :
 forall (A:Type) (B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X:Type => X) A x B y.
Proof.
destruct 1.
subst.
rewrite <- eq_rect_eq.
apply eq_dep_intro.
Qed.

Lemma eq_dep_id_JMeq :
 forall (A: Type) (B:Type) (x:A) (y:B), eq_dep Type (fun X:Type => X) A x B y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

(** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *)

Lemma eq_dep_JMeq :
 forall (U: Type) (P: U -> Type) p x q y, eq_dep U P p x q y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

Lemma eq_dep_strictly_stronger_JMeq :
 exists (U: Type) (P: U -> Type) p q x y, JMeq x y /\ ~ eq_dep U P p x q y.
Proof.
exists bool. exists (fun _ => True). exists true. exists false.
exists I. exists I.
split.
trivial.
intro H.
assert (true=false) by (destruct H; reflexivity).
discriminate.
Qed.

(** However, when the dependencies are equal, [JMeq (P p) x (P q) y]
    is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *)

Lemma JMeq_eq_dep :
  forall (U:Type) (P:U->Prop) p q (x:P p) (y:P q),
  p = q -> JMeq x y -> eq_dep U P p x q y.
Proof.
intros.
destruct H.
apply JMeq_eq in H0 as ->.
reflexivity.
Qed.

(* Compatibility *)
Notation sym_JMeq := JMeq_sym (only parsing).
Notation trans_JMeq := JMeq_trans (only parsing).

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

The following is the original floyd/jmeq_lemmas.v

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

Lemma eq_rect_JMeq: forall (A:Type) (x y: A) (F: A -> Type) (v: F x) (H: x = y), JMeq (eq_rect x F v y H) v.
Proof.
  intros.
  subst.
  rewrite <- eq_rect_eq.
  apply JMeq_refl.
Qed.

Lemma eq_rect_r_JMeq: forall (A:Type) (x y: A) (F: A -> Type) (v: F x) (H: y = x), JMeq (eq_rect_r F v H) v.
Proof.
  intros.
  subst.
  unfold eq_rect_r; rewrite <- eq_rect_eq.
  apply JMeq_refl.
Qed.

Lemma JMeq_sumtype_ll: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A) (y: C), @eq Type A C -> @eq Type B D ->
  (@JMeq (A + B) (inl x) (C + D) (inl y)) ->
  JMeq x y.
Proof.
  intros.
  exists H.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
  apply eq_refl.
Qed.

Lemma JMeq_sumtype_rr: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: B) (y: D), @eq Type A C -> @eq Type B D ->
  (@JMeq (A + B) (inr x) (C + D) (inr y)) ->
  JMeq x y.
Proof.
  intros.
  exists H0.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
  apply eq_refl.
Qed.

Lemma JMeq_sumtype_lr: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A) (y: D), @eq Type A C -> @eq Type B D -> ~ (@JMeq (A + B) (inl x) (C + D) (inr y)).
Proof.
  unfold not.
  intros.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
Qed.

Lemma JMeq_sumtype_rl: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: B) (y: C), @eq Type A C -> @eq Type B D -> ~ (@JMeq (A + B) (inr x) (C + D) (inl y)).
Proof.
  unfold not.
  intros.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
Qed.

Ltac solve_JMeq_sumtype H :=
  match type of H with
  | JMeq ?x ?y =>
    destruct x; destruct y;
     [apply JMeq_sumtype_ll in H; auto
     |apply JMeq_sumtype_lr in H; auto; inversion H
     |apply JMeq_sumtype_rl in H; auto; inversion H
     |apply JMeq_sumtype_rr in H; auto]
  end.

Lemma JMeq_inl: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A) (y: C), @eq Type B D -> JMeq x y -> @JMeq (A + B) (inl x) (C + D) (inl y).
Proof.
  intros.
  destruct H0 as [?H ?H].
  pose (f_equal2 :=
          fun (A1 : Type) (A2 : Type) (B : Type) (f : forall (_ : A1) (_ : A2), B)
            (x1 y1 : A1) (x2 y2 : A2) (H : @eq A1 x1 y1) =>
          match H in (eq _ y) return (forall _ : @eq A2 x2 y2, @eq B (f x1 x2) (f y y2)) with
          | eq_refl => fun H0 : @eq A2 x2 y2 => match H0 in (eq _ y) return (@eq B (f x1 x2) (f x1 y)) with
                                                | eq_refl => @eq_refl B (f x1 x2)
                                                end
          end).
  exists (f_equal2 _ _ _ sum _ _ _ _ H0 H).
  destruct H, H0.
  rewrite <- H1.
  unfold f_equal2.
  simpl.
  apply eq_refl.
Qed.

Lemma JMeq_inr: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: B) (y: D), @eq Type A C -> JMeq x y -> @JMeq (A + B) (inr x) (C + D) (inr y).
Proof.
  intros.
  destruct H0 as [?H ?H].
  pose (f_equal2 :=
          fun (A1 : Type) (A2 : Type) (B : Type) (f : forall (_ : A1) (_ : A2), B)
            (x1 y1 : A1) (x2 y2 : A2) (H : @eq A1 x1 y1) =>
          match H in (eq _ y) return (forall _ : @eq A2 x2 y2, @eq B (f x1 x2) (f y y2)) with
          | eq_refl => fun H0 : @eq A2 x2 y2 => match H0 in (eq _ y) return (@eq B (f x1 x2) (f x1 y)) with
                                                | eq_refl => @eq_refl B (f x1 x2)
                                                end
          end).
  exists (f_equal2 _ _ _ sum _ _ _ _ H H0).
  destruct H, H0.
  rewrite <- H1.
  unfold f_equal2.
  simpl.
  apply eq_refl.
Qed.

Lemma JMeq_fst: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A*B) (y: C*D), @eq Type A C -> @eq Type B D -> JMeq x y -> JMeq (fst x) (fst y).
Proof.
  intros.
  exists H.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  rewrite H2.
  apply eq_refl.
Qed.

Lemma JMeq_snd: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A*B) (y: C*D), @eq Type A C -> @eq Type B D -> JMeq x y -> JMeq (snd x) (snd y).
Proof.
  intros.
  exists H0.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  rewrite H2.
  apply eq_refl.
Qed.

Lemma JMeq_pair: forall (A: Type) (B: Type) (C: Type) (D: Type) (a: A) (b: B) (c: C) (d: D), JMeq a b -> JMeq c d -> JMeq (a, c) (b, d).
Proof.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  pose (f_equal2 :=
          fun (A1 : Type) (A2 : Type) (B : Type) (f : forall (_ : A1) (_ : A2), B)
            (x1 y1 : A1) (x2 y2 : A2) (H : @eq A1 x1 y1) =>
          match H in (eq _ y) return (forall _ : @eq A2 x2 y2, @eq B (f x1 x2) (f y y2)) with
          | eq_refl => fun H0 : @eq A2 x2 y2 => match H0 in (eq _ y) return (@eq B (f x1 x2) (f x1 y)) with
                                                | eq_refl => @eq_refl B (f x1 x2)
                                                end
          end).
  exists (f_equal2 _ _ _ prod _ _ _ _ H H0).
  destruct H, H0.
  rewrite <- H1, <- H2.
  unfold f_equal2.
  simpl.
  apply eq_refl.
Qed.

Lemma eq_rect_r_eq_rect_r_eq_sym: forall {T} {A B: T} F x (H: A = B),
  eq_rect_r F (eq_rect_r F x H) (eq_sym H) = x.
Proof.
  intros.
  destruct H.
  reflexivity.
Qed.

Lemma eq_rect_r_eq_rect_r_eq_sym': forall {T} {A B: T} F x (H: B = A),
  eq_rect_r F (eq_rect_r F x (eq_sym H)) H = x.
Proof.
  intros.
  destruct H.
  reflexivity.
Qed.

Lemma JMeq_func: forall (A: Type) (B: Type) (C: Type) (D: Type) (f: A -> B) (g: C -> D) x y,
  @eq Type B D ->
  JMeq x y -> JMeq f g -> JMeq (f x) (g y).
Proof.
  intros.
  exists H.
  destruct H0 as [?H ?H], H1 as [?H ?H].
  destruct H, H0.
  rewrite <- eq_rect_eq in H3.
  rewrite H3, <- H2.
  apply eq_refl.
Qed.

Lemma eq_JMeq: forall A (x y: A), x=y -> JMeq x y.
Proof. intros. subst. apply JMeq_refl.
Qed.

Lemma list_func_JMeq: forall {A: Type} {B: Type} {C: Type} (a: list A) (b: list B) (f: forall X, list X -> C), @eq Type A B -> JMeq a b -> f A a = f B b.
Proof.
  intros.
  destruct H0 as [? ?].
  destruct H.
  rewrite <- eq_rect_eq in e.
  rewrite e.
  auto.
Qed.

Lemma list_func_JMeq': forall {A: Type} {B: Type} (a: list A) (b: list B) (a': A) (b': B) (f: forall X, list X -> X -> X), JMeq a b -> JMeq a' b' -> JMeq (f A a a') (f B b b').
Proof.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  exists H0.
  rewrite <- H1, <- H2.
  destruct H0.
  simpl.
  rewrite <- eq_rect_eq.
  apply eq_refl.
Qed.

Lemma JMeq_sigT: forall {A: Type} {B: Type} (a: A), @eq Type A B -> {b: B | JMeq a b}.
Proof.
  intros.
  unfold JMeq.
  destruct H.
  exists a.
  apply JMeq_refl.
Qed.

Arguments JMeq_eq {A} {x y} _.


Require Import Coq.Strings.Ascii.

Load Trie.

Open Scope char_scope.

(* Let's add a few words to a trie mapping lists of ASCII characters to natural numbers. *)

Definition empty := empty_trie ascii nat.

Definition hello := trie_insert ascii_dec empty ["h"; "e"; "l"; "l"; "o"] 1.

Definition happy := trie_insert ascii_dec hello ["h"; "a"; "p"; "p"; "y"] 2.

Definition world := trie_insert ascii_dec happy ["w"; "o"; "r"; "l"; "d"] 3.

(* Compute the whole trie. *)

Compute world.

(* Grab a value from the tree. *)

Compute trie_get ascii_dec world ["h"; "a"; "p"; "p"; "y"].


(***********************************************************************)
(** * Lemmas of LJm *)
(***********************************************************************)

(** This file containes lemmas for a locally-nameless
    representation of the intuitionistic sequent calculus lambda-Jm .  *)

Require Import Metalib.Metatheory.
Require Import Stlc.Definitions.
Require Import LJm.Definitions.

Import LJmNotations.

(*************************************************************************)
(** ** Some proofs                                                       *)
(*************************************************************************)

(** The decidable var equality function returns a sum. If the two
    vars are equal, the left branch of the sum is returned, carrying
    a proof of the proposition that the vars are equal.  If they are
    not equal, the right branch includes a proof of the disequality.

    The demo below uses three new tactics:
    - The tactic [simpl] reduces a Coq expression to its normal
      form.
    - The tactic [destruct (Y==Y)] considers the two possible
      results of the equality test.
*)

Example demo_subst1:
  [Y ~> var_f Z] (abs (app (var_b 0) (args (var_f Y) anil (cabs (var_b 0))))) =
                  (abs (app (var_b 0) (args (var_f Z) anil (cabs (var_b 0))))).
Proof.
  simpl.
  destruct (Y==Y).
  - reflexivity.
  - destruct n. auto.
Qed.

(*************************************************************************)
(** ** about testIN                                                      *)
(*************************************************************************)

(*************************************************************************)
(** ** about append                                                      *)
(*************************************************************************)

(*************************************************************************)
(** ** about typing                                                      *)
(*************************************************************************)

(*************************************************************************)
(** ** Local closure *)
(*************************************************************************)

(** The local closure judgement classifies terms that have _no_ dangling
   indices.

   Step through this derivation to see why the term
   [((\x. Y (x,anil,(x)x)) (Y,anil,(x)x)]  is locally closed.
*)

(*************************************************************************)
(** ** Properties about basic operations *)
(*************************************************************************)

(** The most important properties about open and lc concern their
    relationship with the free variable and subst functions.

    For example, one important property is shown below: that we can commute
    free and bound variable substitution.
 *)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Replacement_A.

Coq < Goal forall s t u:Prop, (s -> ~(t /\ u)) <-> (s -> (~t \/ ~u)).
1 subgoal

  ============================
   forall s t u : Prop, s -> ~ (t /\ u) <-> s -> ~ t \/ ~ u

Unnamed_thm < intros.
1 subgoal

  s : Prop
  t : Prop
  u : Prop
  ============================
   s -> ~ (t /\ u) <-> s -> ~ t \/ ~ u

Unnamed_thm < Require Import Classical.

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Section Replacement_A.
Goal forall s t u:Prop, (s -> ~(t /\ u)) <-> (s -> (~t \/ ~u)).
intros.
Require Import Classical.
tauto.
Qed.


(** Coq coding by choukh, June 2022 **)

From HF Require Export HF Extensionality.

(** 单集与配对 **)
Section SingPair.
Context {𝓜 : HF}.
Implicit Types x y a b : 𝓜.

Lemma 单集 x a : x ∈ {a,} ↔ x = a.
Proof. hf. Qed.

Lemma 单集单射 x y : {x,} = {y,} → x = y.
Proof. intros eq. apply 单集. rewrite <- eq. hf. Qed.

Lemma 配对 x a b : x ∈ {a, b} ↔ x = a ∨ x = b.
Proof. hf. Qed.

Lemma 配对单射 x y a b : {x, y} = {a, b} → x = a ∧ y = b ∨ x = b ∧ y = a.
Proof.
  intros A.
  assert (B: x = a ∨ x = b). apply 配对. rewrite <- A. hf.
  assert (C: y = a ∨ y = b). apply 配对. rewrite <- A. hf.
  assert (D: a = x ∨ a = y). apply 配对. rewrite A. hf.
  assert (E: b = x ∨ b = y). apply 配对. rewrite A. hf.
  firstorder.
Qed.

End SingPair.

(** 二元并 *)
Section BinaryUnion.
Context {𝓜 : HF}.
Implicit Types x y z u : 𝓜.

Lemma 二元并强存在 x y : Σ u, ∀ z, z ∈ u ↔ z ∈ x ∨ z ∈ y.
Proof.
  hf_ind x.
  - exists y. hf.
  - intros x x' _ [u IH]. exists (x ⨮ u). hf.
Qed.

Definition 并 x y := projT1 (二元并强存在 x y).

Fact 二元并 x y z : z ∈ 并 x y ↔ z ∈ x ∨ z ∈ y.
Proof. unfold 并. destruct (二元并强存在 x y); auto. Qed.

End BinaryUnion.
Notation "A ∪ B" := (二元并 A B) (at level 50) : hf_scope.

(** 分离 *)
Section Separation.
Context {𝓜 : HF}.
Implicit Types x y z : 𝓜.
Variable P : 可判定谓词 𝓜.

Lemma 分离强存在 x : Σ y, ∀ z, z ∈ y ↔ z ∈ x ∧ P z.
Proof.
  hf_ind x.
  - exists ∅. hf.
  - intros x x' _ [y IH]. destruct (谓词判定 P x).
    + exists (x ⨮ y). hf.
    + exists y. hf.
Qed.

Definition 分 x := projT1 (分离强存在 x).

Lemma 分离 x y : y ∈ 分 x ↔ y ∈ x ∧ P y.
Proof. unfold 分. destruct (分离强存在 x); auto. Qed.

End Separation.
Notation "A ∩ₚ P" := (分 A P) (at level 60) : hf_scope.

(** 替代 *)
Section Replacement.
Context {𝓜 : HF}.
Implicit Types x y a b : 𝓜.
Variable f : 𝓜 → 𝓜.

Lemma 替代强存在 a : Σ b, ∀ y, y ∈ b ↔ ∃ x, x ∈ a ∧ f x = y.
Proof.
  hf_ind a.
  - exists ∅. hf.
  - intros x x' _ [b IH]. exists (f x ⨮ b). hf.
Qed.

Definition 替 x := projT1 (替代强存在 x).

Lemma 替代 a y : y ∈ 替 a ↔ ∃ x, x ∈ a ∧ f x = y.
Proof. unfold 替. destruct (替代强存在 a); auto. Qed.

End Replacement.
Notation "f [ a ]" := (替 f a) (at level 7, format "f [ a ]") : hf_scope.