(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Import digits.
From QArithSternBrocot Require Import R_addenda.
Require Import Fourier_solvable_ineqs.
Require Import Fourier.
Require Import Bounded_M.

(** Properties of the predicate [Refining_M]. *)

Open Scope Q_scope.

Lemma Bounded_M_auxiliary_5: forall c d r, Zero <= d + c -> Zero <= d - c ->(-1<=r<=1)%R->(0<=c*r+d)%R.
Proof.
 intros c d r H1 H2 Hr.
 (* TP : Zero<=d *)
 assert (Hd: Zero<=d);
 [apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto; stepl Zero; auto; stepr ((d+c)+(d-c)); auto; ring|].

 destruct (Qtrichotomy_inf Zero c) as [[Hc|Hc]|Hc]; realify_Q.
   intros; apply Bounded_M_pos_auxiliary_3; trivial.
   intros Hc _ _ Hd; rewrite <- Hc; stepr d; trivial; ring.
   intros; apply Bounded_M_pos_auxiliary_4; trivial.
Qed.

Lemma Bounded_M_auxiliary_6: forall c d r, d + c<=Zero -> d - c<=Zero ->(-1<=r<=1)%R->(c*r+d<=0)%R.
Proof.
 intros c d r H1 H2 Hr.
 (* TP : d<=Zero *)
 assert (Hd: d<=Zero);
 [apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto; stepr Zero; auto; stepl ((d+c)+(d-c)); auto; ring|].

 destruct (Qtrichotomy_inf Zero c) as [[Hc|Hc]|Hc]; realify_Q.
   intros; apply Bounded_M_neg_auxiliary_3; trivial.
   intros Hc _ _ Hd; rewrite <- Hc; stepl d; trivial; ring.
   intros; apply Bounded_M_neg_auxiliary_4; trivial.
Qed.

Lemma Is_refining_M_auxiliary_1: forall (a b c d:Q), Zero <= a + b + c + d -> Zero <= a - b - c + d ->
                                                     Zero <= - a - b + c + d -> Zero <= - a + b - c + d ->
         Zero<=d/\Zero<=d-c/\Zero<=d+c/\Zero<=d-b/\Zero<=d+b/\Zero<=d-a/\Zero<=d+a.
Proof.
 let
 t_local:= apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto; stepl Zero; auto
 in
 ( intros a b c d H1 H2 H3 H4; repeat split;
 [ apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone+Qone); auto; stepl Zero; auto;
   stepr ((a + b + c + d)+(- a - b + c + d)+(a - b - c + d)+(- a + b - c + d))
 | t_local; stepr ((a - b - c + d)+(- a + b - c + d))
 | t_local; stepr ((a + b + c + d)+(- a - b + c + d))
 | t_local; stepr ((a - b - c + d)+(- a - b + c + d))
 | t_local; stepr ((a + b + c + d)+(- a + b - c + d))
 | t_local; stepr ((- a - b + c + d)+(- a + b - c + d))
 | t_local; stepr ((a + b + c + d)+(a - b - c + d))
 ];
 auto; ring).
Qed.

Lemma Is_refining_M_auxiliary_2: forall (a b c d:Q), a + b + c + d <= Zero -> a - b - c + d <= Zero ->
                                                     - a - b + c + d <= Zero -> - a + b - c + d <= Zero ->
                 d<=Zero/\d-c<=Zero/\d+c<=Zero/\d-b<=Zero/\d+b<=Zero/\d-a<=Zero/\d+a<=Zero.
Proof.
 let
 t_local:= apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto; stepr Zero; auto
 in
 ( intros a b c d H1 H2 H3 H4; repeat split;
 [ apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone+Qone); auto; stepr Zero; auto;
   stepl ((a + b + c + d)+(- a - b + c + d)+(a - b - c + d)+(- a + b - c + d))
 | t_local; stepl ((a - b - c + d)+(- a + b - c + d))
 | t_local; stepl ((a + b + c + d)+(- a - b + c + d))
 | t_local; stepl ((a - b - c + d)+(- a - b + c + d))
 | t_local; stepl ((a + b + c + d)+(- a + b - c + d))
 | t_local; stepl ((- a - b + c + d)+(- a + b - c + d))
 | t_local; stepl ((a + b + c + d)+(a - b - c + d))
 ];
 auto; ring).
Qed.

Lemma Is_refining_M_d_minusplus_c_sign_dec: forall a b c d, Is_refining_M ((a,b),(c,d))->
              (Qle Zero (Qplus (Qplus (Qplus a b) c) d) /\ Qle Zero (Qplus (Qminus (Qminus a b) c) d) /\
               Qle Zero (Qplus (Qplus (Qminus (Qopp a) b) c) d) /\ Qle Zero (Qplus (Qminus (Qplus (Qopp a) b) c) d) /\
               Qlt Zero (Qminus d c)/\Qlt Zero (Qplus d c)/\Qlt Zero d) \/
              (Qle (Qplus (Qplus (Qplus a b) c) d) Zero /\ Qle (Qplus (Qminus (Qminus a b) c) d) Zero /\
	       Qle (Qplus (Qplus (Qminus (Qopp a) b) c) d) Zero /\ Qle (Qplus (Qminus (Qplus (Qopp a) b) c) d) Zero /\
               Qlt (Qminus d c) Zero/\Qlt (Qplus d c) Zero/\Qlt d Zero).
Proof.
 intros a b c d [[[H0 H0']|[H0 H0']] [[H1 [H2 [H3 H4]]]|[H1 [H2 [H3 H4]]]]]; unfold fst, snd in H0, H0', H1, H2, H3, H4;
 first [generalize (Bounded_M_auxiliary_1 _ _ H0 H0')|generalize (Bounded_M_auxiliary_2 _ _ H0 H0')] ;intros Hd;
 tauto ||
 first [decompose record (Is_refining_M_auxiliary_1 _ _ _ _ H1 H2 H3 H4)
       |decompose record (Is_refining_M_auxiliary_2 _ _ _ _ H1 H2 H3 H4)]; contradiction.
Qed.

Close Scope Q_scope.

Lemma Is_refining_M_denom_nonvanishing_M:forall mu r, Is_refining_M mu -> ((-1)<=r<=1)%R -> denom_nonvanishing_M mu r.
Proof.
 intros ((a,b),(c,d)) r H_refining Hr;
 generalize (Is_refining_M_d_minusplus_c_sign_dec _ _ _ _ H_refining); clear H_refining.
 intros [[_[_[_[_[H1 [H2 H3]]]]]]|[_[_[_[_[H1 [H2 H3]]]]]]]; red; simpl; realify_Q; intros H1 H2 H3;
 destruct (Qtrichotomy_inf Zero c) as [[Hc|Hc]|Hc]; realify_Q; intros Hc.
  apply Rlt_not_eq'; apply Bounded_M_pos_auxiliary_1; trivial...
  rewrite <- Hc; stepl d; auto; ring...
  apply Rlt_not_eq'; apply Bounded_M_pos_auxiliary_2; trivial...
  apply Rlt_not_eq; apply Bounded_M_neg_auxiliary_1; trivial...
  rewrite <- Hc; stepl d; auto; ring...
  apply Rlt_not_eq; apply Bounded_M_neg_auxiliary_2; trivial...
Qed.

Lemma Is_refining_M_property:forall mu r, ((-1)<=r<=1)%R->Is_refining_M mu -> ((-1)<=as_Moebius mu r<=1)%R.
Proof.
 intros ((a,b),(c,d)) r Hr H_refining;
 generalize (Is_refining_M_denom_nonvanishing_M _ _ H_refining Hr).
 unfold denom_nonvanishing_M, as_Moebius, fst, snd.
 destruct (Is_refining_M_d_minusplus_c_sign_dec _ _ _ _ H_refining)
     as [[H1 [H2 [H3 [H4 [H7 [H5 H6]]]]]]|[H1 [H2 [H3 [H4 [H7 [H5 H6]]]]]]];
 [ generalize (Is_refining_M_auxiliary_1 _ _ _ _ H1 H2 H3 H4)
 | generalize (Is_refining_M_auxiliary_2 _ _ _ _ H1 H2 H3 H4)
 ];
 intros [H12 [H13 [H14 [H8 [H9 [H10 H11]]]]]];
 realify_Q; intros H1 H2 H3 H4 H7 H5 H6 H12 H13 H14 H8 H9 H10 H11 H_denom.
  (* everything is positive *)
   (* TP: 0 < c*r+d *)
   assert (H_crd:0<c*r+d);
   [ destruct (Qtrichotomy_inf Zero c) as [[Hc|Hc]|Hc]; realify_Q; intros Hc;
     [ (* 0<c *) apply Bounded_M_pos_auxiliary_1; trivial
     | (* c=0 *) rewrite <- Hc; stepr d; auto; ring
     | (* c<0 *) apply Bounded_M_pos_auxiliary_2; trivial]
   |].

  split.

   (* lower bound *)
   destruct (Qtrichotomy_inf Zero (Qplus c a)) as [[Hca|Hca]|Hca]; realify_Q; intros Hca;
   (stepl (-1/1); [|field; auto]); apply Rmult_Rdiv_pos_Rle; auto; apply Rle_zero_Rminus; (stepr ((c+a)*r+(d+b)); [|ring]).
    (* 0<c+a *)
    apply Bounded_M_pos_auxiliary_3; trivial; ring_exact_R H4.
    (* c+a=0 *)
    rewrite <- Hca; stepr (d+b); auto; ring.
    (* 0<c+a *)
    apply Bounded_M_pos_auxiliary_4; trivial; ring_exact_R H1...
   (* upper bound *)
   destruct (Qtrichotomy_inf Zero (Qminus c a)) as [[Hca|Hca]|Hca]; realify_Q; intros Hca;
   (stepr (1/1); [|field; auto]); apply Rmult_Rdiv_pos_Rle; auto; apply Rle_zero_Rminus; (stepr ((c-a)*r+(d-b)); [|ring]).
    (* 0<c+a *)
    apply Bounded_M_pos_auxiliary_3; trivial; ring_exact_R H2.
    (* c+a=0 *)
    rewrite <- Hca; stepr (d-b); auto; ring.
    (* 0<c+a *)
    apply Bounded_M_pos_auxiliary_4; trivial; ring_exact_R H3...
  (* everything is negative *)
   (* TP: c*r+d < 0 *)
   assert (H_crd:c*r+d<0);
   [ destruct (Qtrichotomy_inf Zero c) as [[Hc|Hc]|Hc]; realify_Q; intros Hc;
     [ (* 0<c *) apply Bounded_M_neg_auxiliary_1; trivial
     | (* c=0 *) rewrite <- Hc; stepl d; auto; ring
     | (* c<0 *) apply Bounded_M_neg_auxiliary_2; trivial]
   |].

  split.

   (* lower bound *)
   destruct (Qtrichotomy_inf Zero (Qplus c a)) as [[Hca|Hca]|Hca]; realify_Q; intros Hca;
   (stepl (1/(-1)); [|field; auto]); apply Rmult_Rdiv_neg_Rle; auto; apply Rminus_le; (stepl ((c+a)*r+(d+b)); [|ring]).
    (* 0<c+a *)
    apply Bounded_M_neg_auxiliary_3; trivial; ring_exact_R H1.
    (* c+a=0 *)
    rewrite <- Hca; stepl (d+b); auto; ring.
    (* 0<c+a *)
    apply Bounded_M_neg_auxiliary_4; trivial; ring_exact_R H4...
   (* upper bound *)
   destruct (Qtrichotomy_inf Zero (Qminus c a)) as [[Hca|Hca]|Hca]; realify_Q; intros Hca;
   (stepr (-1/-1); [|field; auto]); apply Rmult_Rdiv_neg_Rle; auto; apply Rminus_le; (stepl ((c-a)*r+(d-b)); [|ring]).
    (* 0<c+a *)
    apply Bounded_M_neg_auxiliary_3; trivial; ring_exact_R H3.
    (* c+a=0 *)
    rewrite <- Hca; stepl (d-b); auto; ring.
    (* 0<c+a *)
    apply Bounded_M_neg_auxiliary_4; trivial; ring_exact_R H2...
Qed.

Lemma denom_nonvanishing_M_product:forall mu mu' r,Is_refining_M mu ->((-1)<=as_Moebius mu' r<=1)%R->
                denom_nonvanishing_M mu' r-> denom_nonvanishing_M (product mu mu') r.
Proof.
 intros ((a,b),(c,d)) ((a',b'),(c',d')) r.
 unfold as_Moebius, denom_nonvanishing_M, product, fst, snd.
 intros  H_refining Hr H_denom.
 repeat rewrite Q_to_Rplus; repeat rewrite Q_to_Rmult.
 stepl (c*(a'*r+b')+d*(c'*r+d')); [|ring].
 apply Rlinear_non_zero_2; auto.
 apply (Is_refining_M_denom_nonvanishing_M _ _ H_refining Hr).
Qed.

Lemma Is_refining_M_Bounded_M_product:forall mu mu',Is_refining_M mu' -> Bounded_M mu ->
                   Bounded_M (product mu mu').
Proof.
 intros ((a,b),(c,d)) ((a',b'),(c',d')) H_refining' H_bounded.
 apply denom_nonvanishing_M_Bounded_M; intros r Hr.
 assert (H_mu':=Is_refining_M_property _ r Hr H_refining').
 generalize (Bounded_M_denom_nonvanishing_M _ H_bounded _ H_mu').
 unfold as_Moebius, denom_nonvanishing_M, product, fst, snd.
 intros H_denom.
 repeat rewrite Q_to_Rplus; repeat rewrite Q_to_Rmult.
 stepl (c*(a'*r+b')+d*(c'*r+d')); [|ring].
 apply Rlinear_non_zero_2; auto.
 apply (Is_refining_M_denom_nonvanishing_M _ _ H_refining' Hr).
Qed.

Lemma as_Moebius_product : forall mu mu' r, denom_nonvanishing_M mu' r -> ((-1)<=as_Moebius mu' r<=1)%R ->
                     Is_refining_M mu ->  as_Moebius (product mu mu') r = as_Moebius mu (as_Moebius mu' r).
Proof.
 intros ((a,b),(c,d)) ((a',b'),(c',d')) r H_denom H_mu'_r H_refining.
 generalize (denom_nonvanishing_M_product _ _ _ H_refining H_mu'_r H_denom).
 generalize H_denom; clear H_denom.
 unfold as_Moebius, denom_nonvanishing_M, product, fst, snd.
 realify_Q.
 intros H_denom H_denom_prod.
 repeat rewrite Rdiv_Rmult_numerator; trivial.
 repeat rewrite Rdiv_Rplus_Rmult; trivial.
 rewrite Rdiv_Rdiv_simplify; trivial.
  apply (f_equal2 Rdiv); ring.
  stepl ((c * a' + d * c') * r + (c * b' + d * d')); trivial; ring.
Qed.

Open Scope Z_scope.
Open Scope Q_scope.

Lemma Incl_M_absorbs_Is_refining_M_L:forall mu, Incl_M mu LL -> Is_refining_M (product inv_LL mu).
Proof.
 intros ((a,b),(c,d));
 unfold Incl_M, Is_refining_M, Bounded_M, product, inv_digit, map_digits, inv_LL, fst, snd.
 replace ((-1)/2 - 1/2) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace (1/2 + 3/2) with (Qone +Qone); [|qZ_numerals; field; auto];
 replace (3/2 - 1/2) with Qone; [|qZ_numerals; field; auto];
 replace (1/2 + -1/2) with Zero; [|qZ_numerals; field; auto];
 repeat rewrite Qmult_one_right;
 intros [[[H1 H2]|[H1 H2]] [H3 [H4 [H5 H6]]]].

  (* Zero < d-c,d+c *)
  generalize (Qmult_resp_Qle_pos_l _ _ _ H1 H5); generalize (Qmult_resp_Qle_pos_l _ _ _ H1 H6);
  generalize (Qmult_resp_Qle_pos_l _ _ _ H2 H3); generalize (Qmult_resp_Qle_pos_l _ _ _ H2 H4); clear H3 H4 H5 H6;
  repeat rewrite Qmult_zero_right;
  intros H3 H4 H5 H6;
  split; left; repeat split.
   (* TP: boundedness *)
   stepr ((1/2)*((d+c)-(a+b))); [|qZ_numerals; field; auto];
    apply Qlt_mult_pos_pos; auto; apply Qlt_Qminus_Zero; apply Qle_lt_trans with Zero; trivial;
    apply Qmult_resp_Qle_pos_r with (Qone+Qone);  auto.
   stepr ((1/2)*((d-c)-(b-a))); [|qZ_numerals; field; auto];
    apply Qlt_mult_pos_pos; auto; apply Qlt_Qminus_Zero; apply Qle_lt_trans with Zero; trivial;
    apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto.
   (* TP: refining *)
   stepr ((c+d)+(a+b)); [|qZ_numerals; field; auto];
    stepl ((c+d)+(c + d)*(Qopp Qone)); [|ring]; apply Qle_plus_plus; auto.
   stepr (Zero-((b-a)*(Qone+Qone))); [|qZ_numerals; field; auto];
    apply Qle_Qminus_Zero; trivial.
   stepr (Zero-((a+b)*(Qone+Qone))); [|qZ_numerals; field; auto];
    apply Qle_Qminus_Zero; trivial.
   stepr ((d-c)+(b-a)); [|qZ_numerals; field; auto];
    stepl ((d-c)+(d-c)*(Qopp Qone)); [|ring]; apply Qle_plus_plus; auto.
  (* d-c,d+c < Zero *)
  generalize (Qmult_resp_Qle_neg_l _ _ _ H1 H5); generalize (Qmult_resp_Qle_neg_l _ _ _ H1 H6);
  generalize (Qmult_resp_Qle_neg_l _ _ _ H2 H3); generalize (Qmult_resp_Qle_neg_l _ _ _ H2 H4); clear H3 H4 H5 H6;
  repeat rewrite Qmult_zero_right;
  intros H3 H4 H5 H6;
  split; right; repeat split.
   (* TP: boundedness *)
   stepl (((d+c)-(a+b))*(1/2)); [|qZ_numerals; field; auto];
    apply Qlt_mult_neg_pos; auto; apply Qlt_Qminus_Zero_neg; apply Qlt_le_trans with Zero; trivial;
    apply Qmult_resp_Qle_pos_r with (Qone+Qone);  auto.
   stepl (((d-c)-(b-a))*(1/2)); [|qZ_numerals; field; auto];
    apply Qlt_mult_neg_pos; auto; apply Qlt_Qminus_Zero_neg; apply Qlt_le_trans with Zero; trivial;
    apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto.
   (* TP: refining *)
   stepl ((c+d)+(a+b)); [|qZ_numerals; field; auto];
    stepr ((c+d)+(c + d)*(Qopp Qone)); [|ring]; apply Qle_plus_plus; auto.
   stepl (Zero-((b-a)*(Qone+Qone))); [|qZ_numerals; field; auto];
    apply Qle_Qminus_Zero_neg; trivial.
   stepl (Zero-((a+b)*(Qone+Qone))); [|qZ_numerals; field; auto];
    apply Qle_Qminus_Zero_neg; trivial.
   stepl ((d-c)+(b-a)); [|qZ_numerals; field; auto];
    stepr ((d-c)+(d-c)*(Qopp Qone)); [|ring]; apply Qle_plus_plus; auto.
Qed.

Lemma Incl_M_absorbs_Is_refining_M_R:forall mu, Incl_M mu RR -> Is_refining_M (product inv_RR mu).
Proof.
 intros ((a,b),(c,d));
 unfold Incl_M, Is_refining_M, Bounded_M, product, inv_digit, map_digits, inv_RR, fst, snd.
 replace (1/2 - 1/2) with Zero; [|qZ_numerals; field; auto];
 replace (-1/2 + 3/2) with Qone; [|qZ_numerals; field; auto];
 replace (3/2 - -1/2) with (Qone +Qone); [|qZ_numerals; field; auto];
 replace (1/2 + 1/2) with Qone; [|qZ_numerals; field; auto];
 repeat rewrite Qmult_one_right;
 intros [[[H1 H2]|[H1 H2]] [H3 [H4 [H5 H6]]]].
  (* Zero < d-c,d+c *)
  generalize (Qmult_resp_Qle_pos_l _ _ _ H1 H5); generalize (Qmult_resp_Qle_pos_l _ _ _ H1 H6);
  generalize (Qmult_resp_Qle_pos_l _ _ _ H2 H3); generalize (Qmult_resp_Qle_pos_l _ _ _ H2 H4); clear H3 H4 H5 H6;
  repeat rewrite Qmult_zero_right;
  intros H3 H4 H5 H6;
  split; left; repeat split.
   (* TP: boundedness *)
   stepr ((1/2)*((d+c)+(a+b))); [|qZ_numerals; field; auto];
   apply Qlt_mult_pos_pos; auto; apply Qlt_le_reg_pos; trivial; apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto.
   stepr ((1/2)*((d-c)+(b-a))); [|qZ_numerals; field; auto];
   apply Qlt_mult_pos_pos; auto; apply Qlt_le_reg_pos; trivial; apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto.
   (* TP: refining *)
   stepr ((a+b)*(Qone+Qone)); trivial; qZ_numerals; field; auto.
   stepr ((d-c)-(b-a)); [|qZ_numerals; field; auto]; apply Qle_Qminus_Zero; trivial.
   stepr ((c+d)-(a+b)); [|qZ_numerals; field; auto]; apply Qle_Qminus_Zero; trivial.
   stepr ((b-a)*(Qone+Qone)); trivial; qZ_numerals; field; auto.
  (* d-c,d+c < Zero *)
  generalize (Qmult_resp_Qle_neg_l _ _ _ H1 H5); generalize (Qmult_resp_Qle_neg_l _ _ _ H1 H6);
  generalize (Qmult_resp_Qle_neg_l _ _ _ H2 H3); generalize (Qmult_resp_Qle_neg_l _ _ _ H2 H4); clear H3 H4 H5 H6;
  repeat rewrite Qmult_zero_right;
  intros H3 H4 H5 H6;
  split; right; repeat split.
   (* TP: boundedness *)
   stepl (((d+c)+(a+b))*(1/2)); [|qZ_numerals; field; auto];
   apply Qlt_mult_neg_pos; auto; apply Qlt_le_reg_neg; trivial; apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto.
   stepl (((d-c)+(b-a))*(1/2)); [|qZ_numerals; field; auto];
   apply Qlt_mult_neg_pos; auto; apply Qlt_le_reg_neg; trivial; apply Qmult_resp_Qle_pos_r with (Qone+Qone); auto.
   (* TP: refining *)
   stepl ((a+b)*(Qone+Qone)); trivial; qZ_numerals; field; auto.
   stepl ((d-c)-(b-a)); [|qZ_numerals; field; auto]; apply Qle_Qminus_Zero_neg; trivial.
   stepl ((c+d)-(a+b)); [|qZ_numerals; field; auto]; apply Qle_Qminus_Zero_neg; trivial.
   stepl ((b-a)*(Qone+Qone)); trivial; qZ_numerals; field; auto.
Qed.

Lemma Incl_M_absorbs_Is_refining_M_M:forall mu, Incl_M mu MM -> Is_refining_M (product inv_MM mu).
Proof.
 intros ((a,b),(c,d));
 unfold Incl_M, Is_refining_M, Bounded_M, product, inv_digit, map_digits, inv_MM, fst, snd.
 replace (0/1 - 1/1) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace (1/1 + 0/1) with Qone; [|qZ_numerals; field; auto];
 replace (3/1 - 0/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 replace (0/1 + 3/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 repeat rewrite Qmult_one_right;
 intros [[[H1 H2]|[H1 H2]] [H3 [H4 [H5 H6]]]].
  (* Zero < d-c,d+c *)
  generalize (Qmult_resp_Qle_pos_l _ _ _ H1 H5); generalize (Qmult_resp_Qle_pos_l _ _ _ H1 H6);
  generalize (Qmult_resp_Qle_pos_l _ _ _ H2 H3); generalize (Qmult_resp_Qle_pos_l _ _ _ H2 H4); clear H3 H4 H5 H6;
  intros H3 H4 H5 H6;
  split; left; repeat split.
   (* TP: boundedness *)
   stepr ((1/3)*(d+c)); [|qZ_numerals; field; auto]; apply Qlt_mult_pos_pos; auto.
   stepr ((1/3)*(d-c)); [|qZ_numerals; field; auto]; apply Qlt_mult_pos_pos; auto.
   (* TP: refining *)
   stepr ((a+b)+(1/3)*(d+c)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepl Zero; trivial;
    stepr (((a+b)*(Qone+Qone+Qone))-((c + d)*-Qone)); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero; trivial.
   stepr ((a-b)+(1/3)*(d-c)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepl Zero; trivial;
    stepr ((d-c)-((b-a)*(Qone+Qone+Qone))); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero; trivial.
   stepr ((1/3)*(c+d)-(a+b)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepl Zero; trivial;
    stepr ((c+d)-((a+b)*(Qone+Qone+Qone))); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero; trivial.
   stepr ((1/3)*(d-c)+(b-a)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepl Zero; trivial;
    stepr (((b-a)*(Qone+Qone+Qone))-((d-c)*-Qone)); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero; trivial.
  (* d-c,d+c < Zero *)
  generalize (Qmult_resp_Qle_neg_l _ _ _ H1 H5); generalize (Qmult_resp_Qle_neg_l _ _ _ H1 H6);
  generalize (Qmult_resp_Qle_neg_l _ _ _ H2 H3); generalize (Qmult_resp_Qle_neg_l _ _ _ H2 H4); clear H3 H4 H5 H6;
  intros H3 H4 H5 H6;
  split; right; repeat split.
   (* TP: boundedness *)
   stepl ((d+c)*(1/3)); [|qZ_numerals; field; auto]; apply Qlt_mult_neg_pos; auto.
   stepl ((d-c)*(1/3)); [|qZ_numerals; field; auto]; apply Qlt_mult_neg_pos; auto.
   (* TP: refining *)
   stepl ((a+b)+(1/3)*(d+c)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepr Zero; trivial;
    stepl (((a+b)*(Qone+Qone+Qone))-((c + d)*-Qone)); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero_neg; trivial.
   stepl ((a-b)+(1/3)*(d-c)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepr Zero; trivial;
    stepl ((d-c)-((b-a)*(Qone+Qone+Qone))); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero_neg; trivial.
   stepl ((1/3)*(c+d)-(a+b)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepr Zero; trivial;
    stepl ((c+d)-((a+b)*(Qone+Qone+Qone))); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero_neg; trivial.
   stepl ((1/3)*(d-c)+(b-a)); [|qZ_numerals; field; auto];
    apply Qmult_resp_Qle_pos_r with (Qone+Qone+Qone); auto; stepr Zero; trivial;
    stepl (((b-a)*(Qone+Qone+Qone))-((d-c)*-Qone)); [|qZ_numerals; field; auto];apply Qle_Qminus_Zero_neg; trivial.
Qed.

Lemma Incl_M_absorbs_Is_refining_M:forall mu d, Incl_M mu d -> Is_refining_M (product (inv_digit d) mu).
Proof.
 intros mu [ | | ] H_Incl; unfold inv_digit;
 [ apply Incl_M_absorbs_Is_refining_M_L
 | apply Incl_M_absorbs_Is_refining_M_R
 | apply Incl_M_absorbs_Is_refining_M_M
 ]; assumption.
Qed.

Close Scope Q_scope.
Close Scope Z_scope.

Lemma denom_nonvanishing_M_product_inv_L: forall mu r, denom_nonvanishing_M mu r -> ((-1) <= as_Moebius mu r <= 0)%R ->
                                                       denom_nonvanishing_M (product inv_LL mu) r.
Proof.
 intros ((a,b),(c,d)) r.
 unfold product, as_Moebius, denom_nonvanishing_M, inv_LL, fst, snd.
 intros H_denom [Hr1 Hr2].
 destruct (Q_eq_dec c a) as [Hca|Hca].
  (* a=c *)
  destruct (Q_eq_dec d b) as [Hbd|Hbd].
   (* d=b *)
   apply False_ind; subst c d; apply (Rlt_irrefl 1); apply Rle_lt_trans with 0; trivial;
   stepl ((a * r + b)/(a * r + b)); trivial; field; trivial.
   (* d<>b *)
   subst c; stepl ((1%Z/2%Z)*(d-b)).
    apply Rmult_resp_nonzero; realify_Q; auto; apply Rminus_eq_contra; apply Q_to_R_not_eq; trivial.
    realify_Q_goal; auto; change (IZR (Zneg xH)) with (- IZR (Zpos xH))%R; field; auto.
  (* c<>a *)
  realify_Q; auto.
  intros Hca.
  generalize (Rminus_eq_contra _ _ Hca); clear Hca; intro Hca.
  change (IZR 1) with 1; change (IZR (-1)) with (-1); change (IZR 2) with 2.
  stepl (1/2*((c-a)*r+(d-b))); [|field; auto].
  apply Rmult_resp_nonzero; auto.
  apply Rlinear_non_zero_3; trivial.
  intro H_false.
  apply (Rlt_irrefl 1).
  apply Rle_lt_trans with 0; trivial.
  stepl ((a * r + b)/(c * r + d)); trivial.
  subst r.
  repeat rewrite Rdiv_Rmult_numerator; trivial.
  repeat rewrite Rdiv_Rplus_Rmult; trivial.
  assert (H_linear:c * - (d - b) + (c - a) * d<>0);[rewrite (Rmult_comm (c-a) d); apply Rlinear_non_zero_2; trivial|].
  rewrite Rdiv_Rdiv_simplify; trivial.
  apply Req_Rdiv_Rone; trivial; ring.
Qed.

Lemma denom_nonvanishing_M_product_inv_R: forall mu r, denom_nonvanishing_M mu r -> (0 <= as_Moebius mu r <= 1)%R ->
                                                       denom_nonvanishing_M (product inv_RR mu) r.
Proof.
 intros ((a,b),(c,d)) r.
 unfold product, as_Moebius, denom_nonvanishing_M, inv_RR, fst, snd.
 intros H_denom [Hr1 Hr2].
 destruct (Q_eq_dec c (Qopp a)) as [Hca|Hca].
  (* -a=c *)
  destruct (Q_eq_dec d (Qopp b)) as [Hbd|Hbd].
   (* -d=b *)
   apply False_ind; subst c d; apply (Rlt_irrefl (-1)); apply Rlt_le_trans with 0; trivial;
    stepr ((a * r + b)/((-a)%Q * r + (-b)%Q)); trivial; generalize H_denom; clear H_denom; realify_Q;
    intros H_denom; field; trivial.
   (* -d<>b *)
   subst c; stepl ((1%Z/2%Z)*(d+b)).
    apply Rmult_resp_nonzero; realify_Q; auto; intros Hbd; stepl (d-(-b)); [|ring]; apply Rminus_eq_contra; trivial.
    realify_Q; auto; intros Hdb; field; auto.
  (* -c<>a *)
  realify_Q; auto; intros Hca.
  assert (Hca': c + a <> 0); [stepl (c-(-a));[|ring]; apply Rminus_eq_contra; assumption|].
  change (IZR 1) with 1; change (IZR (-1)) with (-1); change (IZR 2) with 2.
  stepl (1/2*((c+a)*r+(d+b))); [|field; auto].
  apply Rmult_resp_nonzero; auto.
  apply Rlinear_non_zero_3; trivial.
  intro H_false.
  apply (Rlt_irrefl (-1)).
  apply Rlt_le_trans with 0; trivial.
  stepr ((a * r + b)/(c * r + d)); trivial.
  subst r.
  repeat rewrite Rdiv_Rmult_numerator; trivial.
  repeat rewrite Rdiv_Rplus_Rmult; trivial.
  assert (H_linear:c * - (d + b) + (c + a) * d<>0);[rewrite (Rmult_comm (c+a) d); apply Rlinear_non_zero_2; trivial|].
  rewrite Rdiv_Rdiv_simplify; trivial.
  apply Req_Ropp_Rdiv_minus_Rone; trivial; ring.
Qed.

Lemma denom_nonvanishing_M_product_inv_M: forall mu r, denom_nonvanishing_M mu r -> ((-1/3) <= as_Moebius mu r <= 1/3)%R ->
                                                       denom_nonvanishing_M (product inv_MM mu) r.
Proof.
 intros ((a,b),(c,d)) r;
 unfold product, as_Moebius, denom_nonvanishing_M, inv_MM, fst, snd;
 intros H_denom [Hr1 Hr2];
 realify_Q; auto; simpl;
 stepl (1/3*(c*r+d)); auto;
 field; repeat apply Rmult_resp_nonzero; auto; stepl 3; auto; ring.
Qed.

Lemma Is_refining_M_L:Is_refining_M (LL:Matrix).
Proof.
 unfold map_digits, Is_refining_M, Bounded_M, fst, snd; split; left; repeat split; auto.
Qed.

Lemma Is_refining_M_R:Is_refining_M (RR:Matrix).
Proof.
 unfold map_digits, Is_refining_M, Bounded_M, fst, snd; split; left; repeat split; auto.
Qed.

Lemma Is_refining_M_M:Is_refining_M (MM:Matrix).
Proof.
 unfold map_digits, Is_refining_M, Bounded_M, fst, snd; split; left; repeat split; auto.
Qed.

Lemma as_Moebius_L: forall mu r, denom_nonvanishing_M mu r -> ((-1)<=as_Moebius mu r<=1)%R->
                                 as_Moebius (product LL mu) r= (((as_Moebius mu r)-1)/((as_Moebius mu r)+3))%R.
Proof.
 intros ((a,b),(c,d)) r H_denom H_r.
 generalize (denom_nonvanishing_M_product _ _ _ Is_refining_M_L H_r H_denom); generalize H_denom H_r; clear H_denom H_r.
 unfold product, as_Moebius, denom_nonvanishing_M, map_digits, fst, snd.
 realify_Q ;auto; simpl.
 replace (2+1) with 3; [|ring].
 intros H_denom Hr H_denom_product.
 assert (H_denom': a*r+b+(c*r+d)*3<>0);
  [apply Rmult_reg_nonzero_l with (1/2); stepl ((1/2*a+3/2*c)*r+(1/2*b+3/2*d)); trivial; field; auto|].
 rewrite Rdiv_Rminus_Rmult; trivial.
 rewrite Rdiv_Rplus_Rmult; trivial.
 rewrite Rdiv_Rdiv_simplify; trivial.
 transitivity (((a * r + b - (c * r + d) * 1)*(1/2))/((a * r + b + (c * r + d) * 3)*(1/2))).
  apply (f_equal2 Rdiv); field; auto.
  apply Rdiv_Rmult_simplify; auto.
Qed.

Lemma as_Moebius_R: forall mu r, denom_nonvanishing_M mu r -> ((-1)<=as_Moebius mu r<=1)%R->
                                 as_Moebius (product RR mu) r= (((as_Moebius mu r)+1)/((-as_Moebius mu r)+3))%R.
Proof.
 intros ((a,b),(c,d)) r H_denom H_r.
 generalize (denom_nonvanishing_M_product _ _ _ Is_refining_M_R H_r H_denom); generalize H_denom H_r; clear H_denom H_r.
 unfold product, as_Moebius, denom_nonvanishing_M, map_digits, fst, snd.
 realify_Q ;auto; simpl.
 replace (2+1) with 3; [|ring].
 intros H_denom Hr H_denom_product.
 assert (H_denom': -(a*r+b)+(c*r+d)*3<>0);
  [apply Rmult_reg_nonzero_l with (1/2); stepl ((-1/2*a+3/2*c)*r+(-1/2*b+3/2*d)); trivial; field; auto|].
 rewrite <- Rdiv_Ropp_numerator; trivial.
 repeat rewrite Rdiv_Rplus_Rmult; trivial.
 rewrite Rdiv_Rdiv_simplify; trivial.
 transitivity (((a * r + b + (c * r + d) * 1)*(1/2))/((-(a * r + b) + (c * r + d) * 3)*(1/2))).
  apply (f_equal2 Rdiv); field; auto.
  apply Rdiv_Rmult_simplify; auto.
Qed.

Lemma as_Moebius_M: forall mu r, denom_nonvanishing_M mu r -> ((-1)<=as_Moebius mu r<=1)%R->
                                 as_Moebius (product MM mu) r= ((as_Moebius mu r)/3)%R.
Proof.
 intros ((a,b),(c,d)) r H_denom H_r.
 generalize (denom_nonvanishing_M_product _ _ _ Is_refining_M_M H_r H_denom); generalize H_denom H_r; clear H_denom H_r.
 unfold product, as_Moebius, denom_nonvanishing_M, map_digits, fst, snd.
 realify_Q ;auto; simpl.
 replace (2+1) with 3; [|ring].
 intros H_denom Hr H_denom_product.
 rewrite Rdiv_Rdiv_Rmult_numerator; auto.
 apply (f_equal2 Rdiv); field; auto.
Qed.

Lemma as_Moebius_inv_L: forall mu r, denom_nonvanishing_M mu r -> ((-1) <= as_Moebius mu r <= 0)%R -> as_Moebius (product inv_LL mu) r = ((3 * as_Moebius mu r + 1) / (- as_Moebius mu r + 1))%R.
Proof.
 intros ((a,b),(c,d)) r H_denom H_r;
 generalize (denom_nonvanishing_M_product_inv_L _ _ H_denom H_r); generalize H_denom H_r; clear H_denom H_r;
 unfold product, as_Moebius, denom_nonvanishing_M, inv_LL, fst, snd;
 realify_Q ;auto; simpl;
 replace (2+1) with 3; [|ring];
 intros H_denom Hr H_denom_product.
 assert (H_denom':    - (a * r + b) + (c * r + d) * 1 <> 0);
 [apply Rmult_reg_nonzero_l with (1/2); stepl ((-1/2*a+1/2*c)*r+(-1/2*b+1/2*d)); trivial; field; auto|].
 rewrite <- Rdiv_Ropp_numerator; trivial.
 rewrite Rdiv_Rmult_numerator; trivial.
 repeat rewrite Rdiv_Rplus_Rmult; trivial.
 rewrite Rdiv_Rdiv_simplify; trivial.
 transitivity (((3 * (a * r + b) + (c * r + d) * 1)*(1/2))/((- (a * r + b) + (c * r + d) * 1)*(1/2))).
  apply (f_equal2 Rdiv); field; auto.
  apply Rdiv_Rmult_simplify; auto.
Qed.

Lemma as_Moebius_inv_R: forall mu r, denom_nonvanishing_M mu r -> (0 <= as_Moebius mu r <= 1)%R -> as_Moebius (product inv_RR mu) r = ((3 * as_Moebius mu r - 1) / (as_Moebius mu r + 1))%R.
Proof.
 intros ((a,b),(c,d)) r H_denom H_r;
 generalize (denom_nonvanishing_M_product_inv_R _ _ H_denom H_r); generalize H_denom H_r; clear H_denom H_r;
 unfold product, as_Moebius, denom_nonvanishing_M, inv_RR, fst, snd;
 realify_Q ;auto; simpl;
 replace (2+1) with 3; [|ring];
 intros H_denom Hr H_denom_product.
 assert (H_denom':    (a * r + b) + (c * r + d) * 1 <> 0);
 [apply Rmult_reg_nonzero_l with (1/2); stepl ((1/2*a+1/2*c)*r+(1/2*b+1/2*d)); trivial; field; auto|].
 rewrite Rdiv_Rmult_numerator; trivial.
 repeat rewrite Rdiv_Rplus_Rmult; trivial.
 rewrite Rdiv_Rminus_Rmult; trivial.
 rewrite Rdiv_Rdiv_simplify; trivial.
 transitivity (((3 * (a * r + b) - (c * r + d) * 1)*(1/2))/(((a * r + b) + (c * r + d) * 1)*(1/2))).
  apply (f_equal2 Rdiv); field; auto.
  apply Rdiv_Rmult_simplify; auto.
Qed.

Lemma as_Moebius_inv_M: forall mu r, denom_nonvanishing_M mu r -> ((-1/3) <= as_Moebius mu r <= 1/3)%R -> as_Moebius (product inv_MM mu) r = (3 * as_Moebius mu r)%R.
Proof.
 intros ((a,b),(c,d)) r H_denom H_r;
 generalize (denom_nonvanishing_M_product_inv_M _ _ H_denom H_r); generalize H_denom H_r; clear H_denom H_r;
 unfold product, as_Moebius, denom_nonvanishing_M, inv_MM, fst, snd;
 realify_Q ;auto; simpl;
 replace (2+1) with 3; [|ring];
 intros H_denom Hr H_denom_product.
 rewrite Rdiv_Rmult_numerator; trivial.
 rewrite (Rmult_comm 3); rewrite <- Rdiv_Rdiv_Rmult_denominator; auto.
 apply (f_equal2 Rdiv); field; auto.
Qed.

Lemma as_Moebius_L_min_one: as_Moebius LL (-1)%R = (-1)%R.
Proof.
 unfold as_Moebius, map_digits, fst, snd;
 realify_Q; auto; simpl; replace (2+1) with 3; [|ring]; replace (1 / 2 * -1 + 3 / 2) with 1; field; auto.
Qed.

Lemma as_Moebius_R_min_one: as_Moebius RR (-1)%R = (0)%R.
Proof.
 unfold as_Moebius, map_digits, fst, snd;
 realify_Q; auto; simpl; replace (2+1) with 3; [|ring]; replace (-1 / 2 * -1 + 3 / 2) with 2; field; auto.
Qed.

Lemma as_Moebius_M_min_one: as_Moebius MM (-1)%R = (-1/3)%R.
Proof.
 unfold as_Moebius, map_digits, fst, snd;
 realify_Q; auto; simpl; replace (2+1) with 3; [|ring]; replace (0/1 * -1 + 3 / 1) with 3; field; auto.
Qed.

Lemma as_Moebius_L_one: as_Moebius LL (1)%R = (0)%R.
Proof.
 unfold as_Moebius, map_digits, fst, snd;
 realify_Q; auto; simpl; replace (2+1) with 3; [|ring]; replace (1 / 2 * 1 + 3 / 2) with 2; field; auto.
Qed.

Lemma as_Moebius_R_one: as_Moebius RR (1)%R = (1)%R.
Proof.
 unfold as_Moebius, map_digits, fst, snd;
 realify_Q; auto; simpl; replace (2+1) with 3; [|ring]; replace (-1 / 2 * 1 + 3 / 2) with 1; field; auto.
Qed.

Lemma as_Moebius_M_one: as_Moebius MM (1)%R = (1/3)%R.
Proof.
 unfold as_Moebius, map_digits, fst, snd;
 realify_Q; auto; simpl; replace (2+1) with 3; [|ring]; replace (0/1 * 1 + 3 / 1) with 3; field; auto.
Qed.

Lemma as_Moebius_endpoints_digits_base_l: forall d:Digit, ((-1)%R<=as_Moebius d (-1)%R)%R.
Proof.
 intros [ | | ];
 [ rewrite as_Moebius_L_min_one
 | rewrite as_Moebius_R_min_one
 | rewrite as_Moebius_M_min_one
 ]; fourier.
Qed.

Lemma as_Moebius_endpoints_digits_base_r: forall d:Digit, (as_Moebius d 1%R<=1)%R.
Proof.
 intros [ | | ];
 [ rewrite as_Moebius_L_one
 | rewrite as_Moebius_R_one
 | rewrite as_Moebius_M_one
 ]; fourier.
Qed.

Open Scope Z_scope.
Open Scope Q_scope.

Lemma Is_refining_M_property_fold:  forall mu, (forall r, (-1 <= r <= 1)%R -> denom_nonvanishing_M mu r)->
  (forall (r : R),(-1 <= r <= 1)%R -> (-1<=as_Moebius mu r<=1)%R) ->  Is_refining_M mu.
Proof.
 intros ((a,b),(c,d)) H_denom H_mu.
 unfold denom_nonvanishing_M in H_denom; simpl in H_denom.
 unfold as_Moebius in H_mu; simpl in H_mu.
 assert (H_dcmin:d-c <>Zero);
 [apply Q_to_R_Qneq; realify_Q; stepl (c*(-1)+d)%R; [|ring]; apply (H_denom (-1)%R min_one_is_in_base_interval)|].
 assert (H_dc:d+c <>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*1+d)%R; [|ring]; apply (H_denom (1)%R one_is_in_base_interval)|].
 assert (Hd: d<>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*0+d)%R; [|ring]; apply H_denom; split; fourier|].
 split; [ apply denom_nonvanishing_M_Bounded_M; assumption|].
 simpl.
 destruct (denom_nonvanishing_M_Bounded_M ((a,b),(c,d)) H_denom) as [[H1 H2]|[H1 H2]]; simpl in H1, H2.
  (* Zero < d + c /\ Zero < d - c *)
  left; repeat split.
   (* 1 *)
   apply Qle_Qdiv_denom_pos_nonneg with (d+c); trivial;
   assert (Hcd:c*Qone+d <> Zero);[stepl (d+c); trivial; ring|];
   stepr (((a*Qone + b)/(c*Qone + d)) - (-  Qone)); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj1 (H_mu (1)%R one_is_in_base_interval)).
   (* 2 *)
   apply Qle_Qdiv_denom_pos_nonneg with (d-c); trivial;
   assert (Hcd:c*(-Qone)+d <> Zero);[stepl (d-c); trivial; ring|];
   stepr (Qone -((a*(-Qone) + b)/(c*(-Qone) + d))); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 3 *)
   apply Qle_Qdiv_denom_pos_nonneg with (d+c); trivial;
   assert (Hcd:c*Qone+d <> Zero);[stepl (d+c); trivial; ring|];
   stepr (Qone-((a*Qone + b)/(c*Qone + d))); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj2 (H_mu (1)%R one_is_in_base_interval)).
   (* 4 *)
   apply Qle_Qdiv_denom_pos_nonneg with (d-c); trivial;
   assert (Hcd:c*(-Qone)+d <> Zero);[stepl (d-c); trivial; ring|];
   stepr (((a*(-Qone) + b)/(c*(-Qone) + d))-(-Qone)); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* d + c < Zero /\ d - c , Zero *)
  right; repeat split.
   (* 1 *)
   apply Qle_Qdiv_denom_neg_nonneg with (d+c); trivial;
   assert (Hcd:c*Qone+d <> Zero);[stepl (d+c); trivial; ring|];
   stepr (((a*Qone + b)/(c*Qone + d)) - (-  Qone)); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj1 (H_mu (1)%R one_is_in_base_interval)).
   (* 2 *)
   apply Qle_Qdiv_denom_neg_nonneg with (d-c); trivial;
   assert (Hcd:c*(-Qone)+d <> Zero);[stepl (d-c); trivial; ring|];
   stepr (Qone -((a*(-Qone) + b)/(c*(-Qone) + d))); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 3 *)
   apply Qle_Qdiv_denom_neg_nonneg with (d+c); trivial;
   assert (Hcd:c*Qone+d <> Zero);[stepl (d+c); trivial; ring|];
   stepr (Qone-((a*Qone + b)/(c*Qone + d))); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj2 (H_mu (1)%R one_is_in_base_interval)).
   (* 4 *)
   apply Qle_Qdiv_denom_neg_nonneg with (d-c); trivial;
   assert (Hcd:c*(-Qone)+d <> Zero);[stepl (d-c); trivial; ring|];
   stepr (((a*(-Qone) + b)/(c*(-Qone) + d))-(-Qone)); [|field; auto];
   apply Qle_Qminus_Zero;
   apply Q_to_R_Qle;
   realify_Q_goal; trivial;
   apply (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
Qed.

Lemma Is_refining_M_product: forall mu mu', Is_refining_M mu -> Is_refining_M mu' -> Is_refining_M (product mu mu').
Proof.
 intros ((a,b),(c,d)) ((a',b'),(c',d')) H_mu H_mu'.
 apply Is_refining_M_property_fold; intros r Ht.
  apply denom_nonvanishing_M_product; trivial;
  [ apply Is_refining_M_property
  | apply Is_refining_M_denom_nonvanishing_M
  ]; trivial.

  rewrite as_Moebius_product; trivial;
  repeat apply Is_refining_M_property; trivial;
  apply Is_refining_M_denom_nonvanishing_M; trivial.
Qed.

Lemma Is_refining_M_product_hd:forall mu alpha, Is_refining_M mu -> Is_refining_M (product mu (map_digits (hd alpha))).
Proof.
 intros mu [[ | | ] alpha] H_mu;
 unfold hd; apply Is_refining_M_product; trivial;
 [apply Is_refining_M_L|apply Is_refining_M_R|apply Is_refining_M_M].
Qed.

Lemma det_nonneg_refining_endpoints:forall a b c d, Is_refining_M ((a,b),(c,d)) -> Zero <= a*d-b*c  ->
       as_Moebius_Q ((a,b),(c,d)) (-Qone)<=as_Moebius_Q ((a,b),(c,d)) Qone.
Proof.
 intros a b c d [H_bounded _] H_det.
 unfold as_Moebius_Q; simpl.
 assert (H : (-1 <= 1)%R) by fourier.
 generalize (det_nonneg_nondecreasing _ _ _ _ (-1) 1 H_bounded H_det min_one_is_in_base_interval one_is_in_base_interval H).
  let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in rationalify_R_goal;
 [ intro H_Rle; apply Q_to_R_Qle; assumption
 | stepl (d-c); try ring; t_local
 | stepl (d+c); try ring;t_local
 ].
Qed.

Lemma det_nonpos_refining_endpoints:forall a b c d, Is_refining_M ((a,b),(c,d)) -> a*d-b*c<= Zero  ->
       as_Moebius_Q ((a,b),(c,d)) Qone<=as_Moebius_Q ((a,b),(c,d)) (-Qone).
Proof.
 intros a b c d [H_bounded _] H_det.
 unfold as_Moebius_Q; simpl.
 assert (H : (-1 <= 1)%R) by fourier.
 generalize (det_nonpos_nonincreasing _ _ _ _ (-1) 1 H_bounded H_det min_one_is_in_base_interval one_is_in_base_interval H).
 let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in rationalify_R_goal;
 [ intro H_Rle; apply Q_to_R_Qle; assumption
 | stepl (d-c); try ring; t_local
 | stepl (d+c); try ring;t_local
 ].
Qed.

Lemma as_Moebius_Q_product: forall mu mu' (q:Q),
  denom_nonvanishing_M mu' q -> -1 <= as_Moebius_Q mu' q -> as_Moebius_Q mu' q <= 1 -> Is_refining_M mu ->
    as_Moebius_Q (product mu mu') q = as_Moebius_Q mu (as_Moebius_Q mu' q).
Proof.
 intros mu mu' q H_denom.
 qZ_numerals.
 intros H_l H_r H_refining.
 apply Q_to_R_Qeq.
 realify_Q.
 intros H_l H_r.
 assert (H1: denom_nonvanishing_M mu (as_Moebius mu' q));
  [apply Is_refining_M_denom_nonvanishing_M; trivial; revert H_l H_r; rewrite Q_to_R_as_Moebius; auto|].
 assert (H2: denom_nonvanishing_M (product mu mu') q);
  [apply denom_nonvanishing_M_product; trivial;revert H_l H_r; rewrite Q_to_R_as_Moebius; auto|].
 revert H_l H_r; repeat rewrite Q_to_R_as_Moebius; trivial.
 intros H_l H_r.
 apply as_Moebius_product; auto.
Qed.

Lemma Is_refining_M_product_init_pure:forall alpha n, Is_refining_M (product_init_pure alpha n).
Proof.
 intros alpha n; revert alpha; induction n; intros [d alpha]; unfold product_init_pure.
  (* O *)
  simpl; apply Is_refining_M_idM.
  (* S n *)
  rewrite Streams_addenda.take_S_n;
  rewrite (Streams_addenda.fold_right_cons product).
  apply Is_refining_M_product.
   simpl; destruct d; [apply Is_refining_M_L|apply Is_refining_M_R|apply Is_refining_M_M].
   unfold map_reals; rewrite Streams_addenda.map_spelled; simpl; apply (IHn alpha).
Qed.

Close Scope Q_scope.
Close Scope Z_scope.


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

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic.

Import fol_notations.

Set Implicit Arguments.

(* * First order definability and closure properties *)

Notation ø := vec_nil.

Opaque fo_term_subst fo_term_map fo_term_sem.

Section fo_definability.

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
           (X : Type) (M : fo_model Σ X).

  Definition fot_definable (f : (nat -> X) -> X) :=
       { t | incl (fo_term_syms t) ls /\ forall φ, fo_term_sem M φ t = f φ }.

  Definition fol_definable (R : (nat -> X) -> Prop) :=
       { A | incl (fol_syms A) ls
          /\ incl (fol_rels A) lr
          /\ forall φ, fol_sem M φ A <-> R φ }.

  (* A FOL definable predicate is always extensional *)

  Fact fot_def_ext t : fot_definable t -> forall φ ψ, (forall n, φ n = ψ n) -> t φ = t ψ.
  Proof.
    intros (k & _ & Hk) phi psi H.
    rewrite <- Hk, <- Hk; apply fo_term_sem_ext; auto.
  Qed.

  Fact fol_def_ext R : fol_definable R -> forall φ ψ, (forall n, φ n = ψ n) -> R φ <-> R ψ.
  Proof.
    intros (A & _ & _ & HA) phi psi H.
    rewrite <- HA, <- HA; apply fol_sem_ext.
    intros; auto.
  Qed.

  (* We derive closure properties *)

  Fact fot_def_proj n : fot_definable (fun φ => φ n).
  Proof. exists (£ n); intros; split; rew fot; auto; intros _ []. Qed.

  Fact fot_def_map (f : nat -> nat) t :
           fot_definable t -> fot_definable (fun φ => t (fun n => φ (f n))).
  Proof.
    intros H; generalize (fot_def_ext H); revert H.
    intros (k & H1 & H2) H3.
    exists (fo_term_map f k); split.
    + rewrite fo_term_syms_map; auto.
    + intro phi; rewrite <- fo_term_subst_map; rew fot.
      rewrite H2; apply H3; intro; rew fot; auto.
  Qed.

  Fact fot_def_comp s v :
        In s ls
      -> (forall p, fot_definable (fun φ => vec_pos (v φ) p))
      -> fot_definable (fun φ => fom_syms M s (v φ)).
  Proof.
    intros H0 H; apply vec_reif_t in H.
    destruct H as (w & Hw).
    exists (in_fot _ w); split; rew fot.
    + intros x [ -> | H ]; auto; revert H.
      rewrite in_flat_map.
      intros (t & H1 & H2).
      apply in_vec_list, in_vec_inv in H1.
      destruct H1 as (p & <- ).
      revert H2; apply Hw.
    + intros phi; rew fot; f_equal.
      apply vec_pos_ext; intros p.
      rewrite vec_pos_map.
      apply Hw; auto.
  Qed.

  Fact fot_def_equiv f g :
         (forall φ, f φ = g φ) -> fot_definable f -> fot_definable g.
  Proof.
    intros E (t & H1 & H2); exists t; split; auto; intro; rewrite H2; auto.
  Qed.

  Fact fol_def_atom r v :
         In r lr
      -> (forall p, fot_definable (fun φ => vec_pos (v φ) p))
      -> fol_definable (fun φ => fom_rels M r (v φ)).
  Proof.
    intros H0 H; apply vec_reif_t in H.
    destruct H as (w & Hw).
    exists (@fol_atom _ _ w); msplit 2.
    + simpl; intro s; rewrite in_flat_map.
      intros (t & H1 & H2).
      apply in_vec_list, in_vec_inv in H1.
      destruct H1 as (p & <- ).
      revert H2; apply Hw.
    + simpl; intros ? [ -> | [] ]; auto.
    + intros phi; simpl.
      apply fol_equiv_ext; f_equal.
      apply vec_pos_ext; intros p.
      rewrite vec_pos_map; apply Hw; auto.
  Qed.

  Fact fol_def_True : fol_definable (fun _ => True).
  Proof. exists (⊥⤑⊥); intros; simpl; msplit 2; try red; simpl; tauto. Qed.

  Fact fol_def_False : fol_definable (fun _ => False).
  Proof. exists ⊥; intros; simpl; msplit 2; try red; simpl; tauto. Qed.

  Fact fol_def_equiv R T :
          (forall φ, R φ <-> T φ) -> fol_definable R -> fol_definable T.
  Proof.
    intros H (A & H1 & H2 & H3); exists A; msplit 2; auto; intro; rewrite <- H; auto.
  Qed.

  Fact fol_def_conj R T :
         fol_definable R -> fol_definable T -> fol_definable (fun φ => R φ /\ T φ).
  Proof.
    intros (A & H1 & H2 & H3) (B & HH4 & H5 & H6); exists (fol_bin fol_conj A B); msplit 2.
    1,2: simpl; intro; rewrite in_app_iff; intros []; auto.
    intro; simpl; rewrite H3, H6; tauto.
  Qed.

  Fact fol_def_disj R T :
         fol_definable R -> fol_definable T -> fol_definable (fun φ => R φ \/ T φ).
  Proof.
    intros (A & H1 & H2 & H3) (B & HH4 & H5 & H6); exists (fol_bin fol_disj A B); msplit 2.
    1,2: simpl; intro; rewrite in_app_iff; intros []; auto.
    intro; simpl; rewrite H3, H6; tauto.
  Qed.

  Fact fol_def_imp R T :
         fol_definable R -> fol_definable T -> fol_definable (fun φ => R φ -> T φ).
  Proof.
    intros (A & H1 & H2 & H3) (B & HH4 & H5 & H6); exists (fol_bin fol_imp A B); msplit 2.
    1,2: simpl; intro; rewrite in_app_iff; intros []; auto.
    intro; simpl; rewrite H3, H6; tauto.
  Qed.

  Fact fol_def_fa (R : X -> (nat -> X) -> Prop) :
          fol_definable (fun φ => R (φ 0) (fun n => φ (S n)))
       -> fol_definable (fun φ => forall x, R x φ).
  Proof.
    intros (A & H1 & H2 & H3); exists (fol_quant fol_fa A); msplit 2; auto.
    intro; simpl; apply forall_equiv.
    intro; rewrite H3; simpl; tauto.
  Qed.

  Fact fol_def_ex (R : X -> (nat -> X) -> Prop) :
          fol_definable (fun φ => R (φ 0) (fun n => φ (S n)))
       -> fol_definable (fun φ => exists x, R x φ).
  Proof.
    intros (A & H1 & H2 & H3); exists (fol_quant fol_ex A); msplit 2; auto.
    intro; simpl; apply exists_equiv.
    intro; rewrite H3; simpl; tauto.
  Qed.

  Fact fol_def_list_fa K l (R : K -> (nat -> X) -> Prop) :
           (forall k, In k l -> fol_definable (R k))
        -> fol_definable (fun φ => forall k, In k l -> R k φ).
  Proof.
    intros H.
    set (f := fun k Hk => proj1_sig (H k Hk)).
    exists (fol_lconj (list_in_map l f)); msplit 2.
    + rewrite fol_syms_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + rewrite fol_rels_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + intros phi.
      rewrite fol_sem_lconj; split.
      * intros H1 k Hk; apply (proj2_sig (H k Hk)), H1.
        change (In (f k Hk) (list_in_map l f)).
        apply In_list_in_map.
      * intros H1 A H2.
        apply In_list_in_map_inv in H2.
        destruct H2 as (k & Hk & ->).
        apply (proj2_sig (H k Hk)); auto.
  Qed.

  Fact fol_def_bounded_fa m (R : nat -> (nat -> X) -> Prop) :
             (forall n, n < m -> fol_definable (R n))
          -> fol_definable (fun φ => forall n, n < m -> R n φ).
  Proof.
    intros H.
    apply fol_def_equiv with (R := fun φ => forall n, In n (list_an 0 m) -> R n φ).
    + intros phi; apply forall_equiv; intro; rewrite list_an_spec; simpl; split; try tauto.
      intros H1 ?; apply H1; lia.
    + apply fol_def_list_fa.
      intros n Hn; apply H; revert Hn; rewrite list_an_spec; lia.
  Qed.

  Fact fol_def_list_ex K l (R : K -> (nat -> X) -> Prop) :
           (forall k, In k l -> fol_definable (R k))
        -> fol_definable (fun φ => exists k, In k l /\ R k φ).
  Proof.
    intros H.
    set (f := fun k Hk => proj1_sig (H k Hk)).
    exists (fol_ldisj (list_in_map l f)); msplit 2.
    + rewrite fol_syms_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + rewrite fol_rels_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + intros phi.
      rewrite fol_sem_ldisj; split.
      * intros (A & H1 & HA).
        apply In_list_in_map_inv in H1.
        destruct H1 as (k & Hk & ->).
        exists k; split; auto.
        apply (proj2_sig (H k Hk)); auto.
      * intros (k & Hk & H1).
        exists (f k Hk); split.
        - apply In_list_in_map.
        - apply (proj2_sig (H k Hk)); auto.
  Qed.

  Fact fol_def_subst (R : (nat -> X) -> Prop) (f : nat -> (nat -> X) -> X) :
          (forall n, fot_definable (f n))
       -> fol_definable R
       -> fol_definable (fun φ => R (fun n => f n φ)).
  Proof.
    intros H1 H2.
    generalize (fol_def_ext H2); intros H3.
    destruct H2 as (A & G1 & G2 & HA).
    set (rho := fun n => proj1_sig (H1 n)).
    exists (fol_subst rho A); msplit 2.
    + red; apply Forall_forall; apply fol_syms_subst.
      * intros n Hn; rewrite Forall_forall.
        intro; apply (fun n => proj2_sig (H1 n)).
      * apply Forall_forall, G1.
    + rewrite fol_rels_subst; auto.
    + intros phi.
      rewrite fol_sem_subst, HA.
      apply H3; intro; unfold rho; rew fot.
      apply (fun n => proj2_sig (H1 n)).
  Qed.

End fo_definability.

Create HintDb fol_def_db.

#[export] Hint Resolve fot_def_proj fot_def_map fot_def_comp fol_def_True fol_def_False : fol_def_db.

Tactic Notation "fol" "def" :=
   repeat ((  apply fol_def_conj
           || apply fol_def_disj
           || apply fol_def_imp
           || apply fol_def_ex
           || apply fol_def_fa
           || (apply fol_def_atom; intro)
           || apply fol_def_subst); auto with fol_def_db); auto with fol_def_db.

Section extra.

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
           (X : Type) (M : fo_model Σ X).

  (* More closure properties *)

  Fact fol_def_iff R T :
         fol_definable ls lr M R
      -> fol_definable ls lr M T
      -> fol_definable ls lr M (fun φ => R φ <-> T φ).
  Proof.
    intros; fol def.
  Qed.

  Fact fol_def_subst2 R t1 t2 :
           fol_definable ls lr M (fun φ => R (φ 0) (φ 1))
        -> fot_definable ls M t1
        -> fot_definable ls M t2
        -> fol_definable ls lr M (fun φ => R (t1 φ) (t2 φ)).
  Proof.
    intros H1 H2 H3.
    set (f n := match n with
        | 0 => t1
        | 1 => t2
        | _ => fun φ => φ 0
      end).
    change (fol_definable ls lr M (fun φ => R (f 0 φ) (f 1 φ))).
    apply fol_def_subst with (2 := H1) (f := f).
    intros [ | [ | n ] ]; simpl; fol def.
  Qed.

  Let env_vec (φ : nat -> X) n := vec_set_pos (fun p => φ (@pos2nat n p)).
  Let env_env (φ : nat -> X) n k := φ (n+k).

  Fact fol_def_vec_fa n (R : vec X n -> (nat -> X) -> Prop) :
           (fol_definable ls lr M (fun φ => R (env_vec φ n) (env_env φ n)))
         -> fol_definable ls lr M (fun φ => forall v, R v φ).
  Proof.
    revert R; induction n as [ | n IHn ]; intros R HR.
    + revert HR; apply fol_def_equiv; intros phi; simpl.
      split; auto; intros ? v; vec nil v; auto.
    + set (T φ := forall v x, R (x##v) φ).
      apply fol_def_equiv with (R := T).
      * intros phi; unfold T; split.
        - intros H v; vec split v with x; auto.
        - intros H ? ?; apply (H (_##_)).
      * unfold T; apply IHn, fol_def_fa, HR.
  Qed.

  Fact fol_def_vec_ex n (R : vec X n -> (nat -> X) -> Prop) :
           (fol_definable ls lr M (fun φ => R (env_vec φ n) (env_env φ n)))
         -> fol_definable ls lr M (fun φ => exists v, R v φ).
  Proof.
    revert R; induction n as [ | n IHn ]; intros R HR.
    + revert HR; apply fol_def_equiv; intros phi; simpl.
      split.
      * exists vec_nil; auto.
      * intros (v & Hv); revert Hv; vec nil v; auto.
    + set (T φ := exists v x, R (x##v) φ).
      apply fol_def_equiv with (R := T).
      * intros phi; unfold T; split.
        - intros (v & x & Hv); exists (x##v); auto.
        - intros (v & Hv); revert Hv; vec split v with x; exists v, x; auto.
      * unfold T; apply IHn, fol_def_ex, HR.
  Qed.

  Fact fol_def_finite_fa I (R : I -> (nat -> X) -> Prop) :
            finite_t I
         -> (forall i, fol_definable ls lr M (R i))
         -> fol_definable ls lr M (fun φ => forall i : I, R i φ).
  Proof.
    intros (l & Hl) H.
    apply fol_def_equiv with (R := fun φ => forall i, In i l -> R i φ).
    + intros phi; apply forall_equiv; intro; split; auto.
    + apply fol_def_list_fa; auto.
  Qed.

  Fact fol_def_finite_ex I (R : I -> (nat -> X) -> Prop) :
            finite_t I
         -> (forall i, fol_definable ls lr M (R i))
         -> fol_definable ls lr M (fun φ => exists i : I, R i φ).
  Proof.
    intros (l & Hl) H.
    apply fol_def_equiv with (R := fun φ => exists i, In i l /\ R i φ).
    + intros phi; apply exists_equiv; intro; split; auto; tauto.
    + apply fol_def_list_ex; auto.
  Qed.

End extra.


Module NatList.

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

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

Inductive listofnatlist : Type :=
  | list_nil
  | list_cons (a : natlist) (l : listofnatlist).


Require Export List.

Require Import CpdtTactics.
Require Import LibTactics.

(*
==================
Lemmas about find
==================
*)

Lemma find_notNone :
  forall A f l,
    find f l <> None <->
    exists (e : A), find f l = Some e.
Proof with eauto.
  induction l.
  + crush.
  + simpl. cases_if...
    split... congruence.
Qed.

Lemma find_in :
  forall A f l (x : A),
    find f l = Some x ->
    In x l.
Proof with auto.
  induction l as [| h t]; crush.
  cases_if; crush.
Qed.

Lemma find_true :
  forall A f l (x : A),
    find f l = Some x ->
    f x = true.
Proof with auto.
  introv Hfind. induction l.
  + inversion Hfind.
  + simpls. cases_if; crush.
Qed.

Lemma find_app :
  forall A f l1 l2 (x : A),
    find f l1 = Some x ->
    find f (l1 ++ l2) = Some x.
Proof with auto.
  introv Hfind. induction l1; simpl.
  + inversion Hfind.
  + simpls. cases_if; crush.
Qed.

Lemma find_app2 :
  forall A f l1 l2 (x : A),
    find f l2 = Some x ->
    find f l1 = None ->
    find f (l1 ++ l2) = Some x.
Proof with auto.
  induction l1; simpls...
  cases_if; crush.
Qed.

(*
==================
Lemmas about snoc
==================
*)

Fixpoint snoc {A:Type} (l : list A) (x : A):=
  match l with
    | nil => x :: nil
    | head :: tail => cons head (snoc tail x)
  end.

Lemma snoc_length :
  forall A l (x : A),
    length (snoc l x) = S (length l).
Proof.
  induction l; crush.
Qed.

Lemma snoc_in :
  forall A l (x : A),
    List.In x (snoc l x).
Proof with auto.
  induction l; crush.
Qed.

Lemma in_snoc :
  forall A l (x y : A),
    List.In x (snoc l y) <->
    List.In x l \/ x = y.
Proof.
  intros. induction l; crush.
Qed.

Lemma NoDup_snoc :
  forall A l (x : A),
    NoDup l ->
    ~ In x l ->
    NoDup (snoc l x).
Proof with eauto using NoDup.
  introv HnDup HnIn.
  induction l; crush...
  inverts HnDup.
  constructors...
  intros contra.
  eapply in_snoc in contra.
  inverts contra...
Qed.

(*
====================
Lemmas about remove
====================
*)

Lemma remove_app :
  forall A l1 l2 (x:A) eq_dec,
    remove eq_dec x (l1 ++ l2) =
    remove eq_dec x l1 ++ remove eq_dec x l2.
Proof with auto.
  induction l1; simpls... intros.
  cases_if; crush.
Qed.

Hint Rewrite remove_app : remove.

Lemma remove_idempotence :
  forall A l (x:A) eq_dec,
    remove eq_dec x (remove eq_dec x l) =
    remove eq_dec x l.
Proof with auto.
  induction l; simpls; intros...
  repeat (elim eq_dec; simpl); crush.
Qed.

Hint Rewrite remove_idempotence : remove.

Lemma remove_commutative :
  forall A l (x y:A) eq_dec,
    remove eq_dec x (remove eq_dec y l) =
    remove eq_dec y (remove eq_dec x l).
Proof with auto.
  induction l; simpl; intros...
  repeat (elim eq_dec; simpl); crush.
Qed.

Hint Rewrite remove_commutative : remove.

Lemma remove_in :
  forall A l (x y : A) eq_dec,
    In x (remove eq_dec y l) ->
    In x l.
Proof with eauto.
  induction l; simpl; intros...
  cases_if; crush...
Qed.

Lemma remove_not_in :
  forall A l (x y : A) eq_dec,
    ~ In x l ->
    ~ In x (remove eq_dec y l).
Proof with eauto.
  induction l; simpl; intros...
  cases_if; crush...
Qed.

Hint Constructors NoDup.

Lemma remove_NoDup :
  forall A l (x : A) eq_dec,
  NoDup l ->
  NoDup (remove eq_dec x l).
Proof with eauto using remove_not_in.
  induction l; simpl; introv Hdup...
  inverts Hdup.
  cases_if...
Qed.

Lemma remove_in_eq :
  forall A l (x : A) eq_dec,
    ~In x (remove eq_dec x l).
Proof with eauto.
  introv.
  induction l...
  simpl. cases_if; crush.
Qed.

Lemma remove_in_neq :
  forall A l (x y : A) eq_dec,
    In x l ->
    x <> y ->
    In x (remove eq_dec y l).
Proof with eauto.
  introv HIn Hneq.
  induction l...
  simpl. cases_if; crush.
Qed.

Lemma remove_not_in_neq :
  forall A (x : A) y l eq_dec,
    x <> y ->
    ~ In x (remove eq_dec y l) ->
    ~ In x l.
Proof with eauto.
  introv Hneq HnIn.
  introv contra. apply HnIn.
  apply remove_in_neq...
Qed.

(*
==================
Lemmas about app
==================
*)

Lemma Forall_app :
  forall A P l1 l2,
    @Forall A P l1 ->
    Forall P l2 ->
    Forall P (l1 ++ l2).
Proof with auto.
  induction l1...
  introv Hforall.
  inversion Hforall.
  constructor...
Qed.

Lemma app_eq_nil :
  forall A l1 l2,
    l1 ++ l2 = nil <-> l1 = nil /\ l2 = @nil A.
Proof with auto using app_eq_nil.
  introv. split... crush.
Qed.

Corollary app_eq_nil_trivial :
  forall A l1 l2,
    l1 = @nil A ->
    l2 = @nil A ->
    l1 ++ l2 = @nil A.
Proof with auto.
  introv Hnil1 Hnil2. apply app_eq_nil...
Qed.

Hint Immediate app_eq_nil_trivial.

Lemma not_in_app :
  forall A l1 l2 (x : A),
    ~ In x (l1 ++ l2) <->
    (~ In x l1) /\ (~ In x l2).
Proof with eauto using in_or_app, in_cons, in_eq.
  intros A l1 l2 x.
  split.
  + introv Hin.
    induction l1...
    simpl in Hin.
    simpl.
    split.
    - intros contra.
      apply Hin. inversion contra...
    - intros contra...
  + introv HIn.
    inverts HIn as HIn1 HIn2.
    induction l1; simpl...
    intros contra.
    inversion contra.
    - apply HIn1. subst...
    - apply IHl1...
Qed.

Hint Constructors NoDup.

Lemma NoDup_app :
  forall A (l1 l2 : list A),
    NoDup (l1 ++ l2) ->
    NoDup l1 /\ NoDup l2.
Proof with eauto.
  introv Hdup.
  induction l1.
  + inversion Hdup...
  + inversion Hdup as [|? ? Hin Hdup'].
    apply IHl1 in Hdup' as (Hdup1 & Hdup2).
    split...
    econstructor...
    apply not_in_app in Hin as []...
Qed.

(*
===================
Lemmas about filter
===================
*)

Lemma filter_in :
  forall A (x : A) p l,
  (forall x y, p x y = true <-> x = y) ->
  (In x l <-> In x (filter (p x) l)).
Proof with eauto.
  introv Hp.
  split.
  + introv HIn. induction l;
    simpl; try(cases_if); crush.
    assert (Heq: x = x)...
    apply Hp in Heq. congruence.
  + introv HIn. induction l;
    simpls; try(cases_if); crush.
Qed.

Lemma filter_not_in :
  forall A (x : A) p l,
  (forall x y, p x y = true <-> x = y) ->
  (~In x l <-> (filter (p x) l) = nil).
Proof with eauto.
  introv Hp.
  split.
  + introv HnIn.
    induction l...
    simpl. cases_if; crush.
    apply Hp in H. false.
  + introv Hneq.
    induction l...
    simpls. cases_if; try(congruence).
    intros contra. inverts contra.
    - assert(p x x = true) by (apply Hp; eauto).
      congruence.
    - apply IHl...
Qed.

Lemma filter_length :
  forall A (l : list A) p,
    length (filter p l) <= length l.
Proof with eauto.
  introv.
  induction l...
  simpl. cases_if; crush.
Qed.

Lemma filter_app :
  forall A (l1 l2 : list A) p,
    filter p (l1 ++ l2) = (filter p l1) ++ (filter p l2).
Proof with eauto.
  introv.
  induction l1...
  simpl. cases_if; crush.
Qed.

Lemma filter_snoc_true :
  forall A (x : A) l p,
    p x = true ->
    filter p (snoc l x) = snoc (filter p l) x.
Proof with eauto.
  introv Hp.
  induction l; crush.
  cases_if...
Qed.

Lemma filter_snoc_false :
  forall A (x : A) l p,
    p x = false ->
    filter p (snoc l x) = filter p l.
Proof with eauto.
  introv Hp.
  induction l; crush.
Qed.

(*
================
Lemmas about in
================
*)

Lemma in_comm :
  forall A l1 l2 (x : A),
    In x (l1 ++ l2) ->
    In x (l2 ++ l1).
Proof with eauto using in_or_app.
  introv HIn.
  apply in_app_or in HIn as []...
Qed.


Require Import util list_util.
Require List.

Set Implicit Arguments.

Class Container (Elem C: Type) := In: Elem -> C -> Prop.
Hint Unfold In.

Notation "x ∈ y" := (In x y) (at level 40).
Notation "x ∉ y" := (In x y -> False) (at level 40).

Instance predicate_container {X}: Container X (X -> Prop) := fun x p => p x.
Hint Unfold predicate_container.

Instance list_container X: Container X (List.list X) := @List.In X.
Implicit Arguments list_container [].

Instance bool_pred_container X: Container X (X -> bool) := fun x p => p x = true.
Implicit Arguments bool_pred_container [].

Section ops_and_props.

  Context {A X} `{Container A X}.

  Definition is_empty (x: X): Prop := forall a, a ∉ x.
  Definition nonempty (x: X): Prop := exists a, a ∈ x.

  Context {Y} `{Container A Y}.

  Definition intersection (c: X) (d: Y) (x: A): Prop := x ∈ c /\ x ∈ d.
  Definition incl (x: X) (y: Y) := forall a, a ∈ x -> a ∈ y.

End ops_and_props.

Notation "x ∩ y" := (intersection x y) (at level 30).
Notation "x ⊆ y" := (incl x y) (at level 40).

Definition overlap {A X} `{Container A X} {Y} `{Container A Y} (c: X) (d: Y): Prop := nonempty (c ∩ d).

Hint Unfold intersection incl.


Require Recdef.
Require Import compcert.lib.Integers.
Require Coq.Strings.String.
Require Coq.Strings.Ascii.
Require Import compcert.lib.Coqlib.
Require Import VST.msl.Coqlib2.
Require Import VST.floyd.coqlib3.
Require Import VST.floyd.sublist.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.SHA256.
Require Import Lia.

(* LINEAR-TIME FUNCTIONAL VERSION OF SHA256 *)
Function zeros (n : Z) {measure Z.to_nat n} : list Int.int :=
 if Z.gtb n 0 then Int.zero :: zeros (n-1) else nil.
Proof.
   intros. rewrite Z2Nat.inj_sub by lia.
   apply Zgt_is_gt_bool in teq.
   assert (0 < n) by lia. apply Z2Nat.inj_lt in H; try lia.
Defined.

Definition padlen (n: Z) : list Int.int :=
    let p := n/4+3 (* number of words with trailing 128-byte,
                                                      up to 3 zero bytes, and 2 length words *)
    in let q := (p+15)/16*16 - p   (* number of zero-pad words *)
      in zeros q ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

Fixpoint generate_and_pad' (n: list byte) len : list Int.int :=
  match n with
  | nil => bytes_to_Int (Byte.repr 128) Byte.zero Byte.zero Byte.zero :: padlen len
  | [h1]=> bytes_to_Int h1 (Byte.repr 128) Byte.zero Byte.zero :: padlen (len+1)
  | [h1; h2] => bytes_to_Int h1 h2 (Byte.repr 128) Byte.zero :: padlen (len+2)
  | [h1; h2; h3] => bytes_to_Int h1 h2 h3 (Byte.repr 128) :: padlen (len+3)
  | h1::h2::h3::h4::t => bytes_to_Int h1 h2 h3 h4 :: generate_and_pad' t (len+4)
  end.

Definition generate_and_pad_alt (n: list byte) : list Int.int :=
   generate_and_pad' n 0.

Definition Wnext (msg : list int) : int :=
 match msg with
 | x1::x2::x3::x4::x5::x6::x7::x8::x9::x10::x11::x12::x13::x14::x15::x16::_ =>
   (Int.add (Int.add (sigma_1 x2) x7) (Int.add (sigma_0 x15) x16))
 | _ => Int.zero  (* impossible *)
 end.

(*generating 64 words for the given message block imput*)
Fixpoint generate_word (msg : list int) (n : nat) {struct n}: list int :=
  match n with
  |O   => msg
  |S n' => generate_word (Wnext msg :: msg) n'
  end.
Arguments generate_word msg n : simpl never.
Global Opaque generate_word. (* for some reason the Arguments...simpl-never
   command does not do the job *)

(*execute round function for 64 rounds*)
Fixpoint rnd_64 (x: registers) (k w : list int) : registers :=
  match k, w with
  | k1::k', w1::w' => rnd_64 (rnd_function x k1 w1) k' w'
  | _ , _ => x
  end.
Arguments rnd_64  x k w : simpl never.  (* blows up otherwise *)

Definition process_block (r: registers) (block: list int) : registers :=
       (map2 Int.add r (rnd_64 r K256 (rev(generate_word block 48)))).

Fixpoint grab_and_process_block (n: nat) (r: registers) (firstrev msg: list int) : registers * list int :=
 match n, msg with
  | O, _ => (process_block r firstrev, msg)
  | S n', m1::msg' => grab_and_process_block n' r (m1::firstrev) msg'
  | _, nil => (r,nil) (* impossible *)
 end.

(*iterate through all the message blocks; this could have been done with just a Fixpoint
  if we incorporated grab_and_process_block into process_msg, but I wanted to
  modularize a bit more. *)
Function process_msg  (r: registers) (msg : list int) {measure length msg}  : registers :=
 match msg with
 | nil => r
 | _ => let (r', msg') := grab_and_process_block 16 r nil msg
             in process_msg r' msg'
 end.
Proof.
  intros; subst.
  simpl.
  assert (Datatypes.length msg' <= Datatypes.length l)%nat; [ | lia].
  simpl in teq0.
  do 16 (destruct l; [inv teq0; solve [simpl; auto 50] | ]).
  unfold process_block in teq0.
  assert (i15::l = msg') by congruence.
  subst msg'.
  simpl.
  lia.
Defined.

Definition SHA_256' (str : list byte) : list byte :=
    intlist_to_bytelist (process_msg init_registers (generate_and_pad_alt str)).

(*EXAMPLES*)

Fixpoint bytelist_eq (al bl: list byte) : bool :=
 match al, bl with
 | nil, nil => true
 | a::al', b::bl' => Byte.eq a b && bytelist_eq al' bl'
 | _, _ => false
  end.

Definition hexdigit(a: Z) : Z :=
 if Z.leb 48 a && Z.ltb a 58 then Z.sub a 48
 else if Z.leb 65 a && Z.ltb a 71 then Z.sub a 55
 else if Z.leb 97 a && Z.ltb a 103 then Z.sub a 87
 else 0%Z.

Fixpoint hexstring_to_bytelist (s: String.string): list byte  :=
 match s with
 | String.String a (String.String b r) => Byte.repr ((hexdigit (Z.of_N (Ascii.N_of_ascii a)) * 16
                                         + hexdigit (Z.of_N (Ascii.N_of_ascii b))))
                                          :: hexstring_to_bytelist r
 | _ => nil
 end.

Section CHECKS.
Import String.
Definition check m h :=
  bytelist_eq (SHA_256' (str_to_bytes m)) (hexstring_to_bytelist h) = true.

(*This input message is 344 bits long, which would have one message block after padding*)
Goal  check   "The quick brown fox jumps over the lazy dog"
  "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592".
Proof. vm_compute; auto. Qed.

(*This input message would have four message blocks after padding*)
Goal check "The Secure Hash Algorithm is a family of cryptographic hash functions published by the National Institute of Standards and Technology (NIST) as a U.S. Federal Information Processing Standard (FIPS)"
 "27c3971526f07a22decc4dc01340c6c4b972ba6d31b74fb1fbb2edf2bce5fea6".
Proof. vm_compute; auto. Qed.
End CHECKS.

(* PROOF OF EQUIVALENCE OF FAST FUNCTIONAL PROGRAM WITH
    FUNCTIONAL SPECIFICATION *)

Require Import sha.common_lemmas.
Require Import VST.msl.Coqlib2.

Local Open Scope nat.

Lemma length_rnd_64:
  forall r k w, length r = 8 -> length (rnd_64 r k w) = 8.
Proof.
intros.
revert r H w; induction k; simpl; intros; auto.
unfold rnd_64; fold rnd_64.
destruct w; auto.
rename H into H0.
repeat  (destruct r as [ | ? r]; rename H0 into H2; inv H2).
apply IHk.
reflexivity.
Qed.

Lemma length_rnd_64_inv:
  forall r k w, length (rnd_64 r k w) = 8 -> length r = 8.
Proof.
intros.
revert w r H; induction k; simpl; intros.
unfold rnd_64 in H; auto.
unfold rnd_64 in H; fold rnd_64 in H.
destruct w; inv H; auto.
rewrite H1.
apply IHk in H1.
clear - H1.
unfold rnd_function in H1.
rename H1 into H0.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0.
simpl.
auto.
Qed.

Lemma length_process_block:
  forall r b, length r = 8 -> length (process_block r b) = 8.
Proof.
 intros. unfold process_block.
 apply length_map2; auto.
 apply length_rnd_64; auto.
Qed.

Lemma length_map2_add_rnd_64:
 forall regs w,
  length regs = 8 ->
  length (map2 Int.add regs (rnd_64 regs K256 w)) = 8.
Proof.
 intros.
 apply length_map2; auto.
 apply length_rnd_64; auto.
Qed.

Lemma grab_and_process_block_length:
 forall n r firstr msg r' m',
    length r = 8 ->
    length msg >= n ->
    grab_and_process_block n r firstr msg  = (r',m') ->
    length r' = 8.
Proof.
 induction n; intros.
 inv H1.
 apply length_process_block; auto.
 destruct msg.
 inv H0.
 simpl in H0.
 apply IHn in H1; auto.
 lia.
Qed.

Lemma length_process_msg:
  forall b, length (process_msg init_registers b) = 8.
Proof.
 intros.
 assert (length init_registers = 8%nat) by reflexivity.
 forget init_registers as regs.
 assert (exists n, n >= length b)%nat by eauto.
 destruct H0 as [n H0].
 revert regs b H H0; induction n; intros; rewrite process_msg_equation.
 destruct b; auto.
 inv H0.
 unfold grab_and_process_block.
 repeat (destruct b; [apply H | ]).
 apply IHn.
 apply length_process_block; auto.
 simpl in H0.
 lia.
Qed.

Lemma process_msg_eq2:
 forall regs hashed b,
  length b = 16 ->
 process_msg regs (b++hashed) =
  process_msg (process_block regs (rev b)) hashed.
Proof.
intros.
rewrite process_msg_equation.
destruct (b++hashed) eqn:?.
destruct b; inv H. inv Heql.
rewrite <- Heql; clear i l Heql.
unfold grab_and_process_block.
rename H into H0.
repeat (destruct b as [ | ?x b]; inv H0; rename H1 into H0).
destruct b; inv H0.
simpl. auto.
Qed.

Lemma rnd_64_S:
  forall regs i b k w,
    nth_error K256 i = Some k ->
    nth_error b i = Some w ->
    rnd_64 regs K256 (firstn (S i) b) =
    rnd_function (rnd_64 regs K256 (firstn i b)) k w.
Proof.
intros.
forget K256 as K'.
assert (firstn (S i) b = firstn i b++[w]).
clear - H0.
revert b w H0; induction i; destruct b; simpl; intros; inv H0; auto.
rewrite <- (IHi _ _ H1).
reflexivity.
rewrite H1.
clear H1.
pose proof (firstn_length i b).
rewrite min_l in H1.
2:{
clear - H0; revert b H0; induction i; destruct b; simpl; intros; inv H0; try lia.
specialize (IHi _ H1). lia.
}
rewrite <- H1 in H.
clear H0 H1.
revert K' k H regs; induction (firstn i b); destruct K'; simpl; intros; inv H.
unfold rnd_64; simpl; fold rnd_64.
destruct K'; reflexivity.
specialize (IHl _ _ H1).
unfold rnd_64; simpl; fold rnd_64.
apply IHl.
Qed.

Lemma Zlength_zeros:
    forall n, (n>=0)%Z -> Zlength (zeros n) = n.
Proof.
intros.
rewrite <- (Z2Nat.id n) in * by lia.
clear H.
induction (Z.to_nat n).
reflexivity.
rewrite inj_S.
rewrite zeros_equation.
pose proof (Zgt_cases (Z.succ (Z.of_nat n0)) 0).
destruct (Z.succ (Z.of_nat n0) >? 0); try lia.
rewrite Zlength_cons.
f_equal.  rewrite <- IHn0.
f_equal. f_equal. lia.
Qed.

Lemma length_zeros: forall n:Z, length (zeros n) = Z.to_nat n.
Proof.
intros. destruct (zlt n 0).
rewrite zeros_equation.
pose proof (Zgt_cases n 0).
destruct (n>?0). lia.
destruct n. inv l. inv l. simpl. reflexivity.
rename g into H.
pose proof (Zlength_zeros n H).
rewrite Zlength_correct in H0.
rewrite <- H0 at 2.
rewrite Nat2Z.id. auto.
Qed.

Hint Rewrite length_zeros : norm.

Local Open Scope Z.

Lemma Zlength_padlen:
 forall n,
  n>=0 ->
  Zlength (padlen n) = roundup (n/4+3) 16 - n/4 - 1.
Proof.
intros.
unfold padlen.
rewrite Zlength_app.
rewrite Zlength_zeros.
repeat rewrite Zlength_cons; rewrite Zlength_nil.
change (Z.succ (Z.succ 0)) with 2.
unfold roundup.
change (16-1) with 15; lia.
assert (n/4 >= 0).
apply Z_div_ge0; lia.
assert (n/4+3>0) by lia.
forget (n/4+3) as d.
clear - H1.
replace (d+15) with ((1*16)+ (d-1)) by (simpl Z.mul; lia).
rewrite Z_div_plus_full_l by lia.
rewrite Z.mul_add_distr_r.
change (1*16) with 16.
assert ((d-1)/16*16 + 15 >= d-1); [ | lia].
assert (d-1>=0) by lia.
forget (d-1) as e.
clear - H.
pattern e at 2; rewrite (Z_div_mod_eq e 16) by lia.
rewrite Z.mul_comm.
 assert (15 >= e mod 16); [| lia].
destruct (Z.mod_pos_bound e 16); lia.
Qed.

Lemma zeros_app:
  forall n m, (n >= 0 -> m >=0 -> zeros n ++ zeros m = zeros (n+m))%Z.
Proof.
intro.
intros ? ?.
rewrite <- (Z2Nat.id n).
induction (Z.to_nat n); intros; try reflexivity.
rewrite inj_S. unfold Z.succ.
rewrite zeros_equation; symmetry; rewrite zeros_equation; symmetry.
replace ( Z.of_nat n0 + 1 + m >? 0) with true.
replace (Z.of_nat n0 + 1 >? 0) with true.
simpl.
f_equal.
rewrite Z.add_simpl_r.
rewrite IHn0; auto.
f_equal; lia.
symmetry; apply Z.gtb_lt; auto; lia.
symmetry; apply Z.gtb_lt; auto; lia.
lia.
Qed.

Lemma zeros_Zsucc:
 forall n, n >= 0 -> zeros (Z.succ n) = Int.repr 0 :: zeros n.
Proof.
intros.
rewrite zeros_equation.
replace (Z.succ n >? 0) with true.
f_equal. f_equal. lia.
symmetry.
apply Z.gtb_lt; lia.
Qed.

Lemma intlist_to_bytelist_zeros:
  forall n:Z, intlist_to_bytelist (zeros n) = map Byte.repr (map Int.unsigned (zeros (4*n)%Z)).
Proof.
intro.
destruct (zlt n 0).
destruct n; try lia. inv l. reflexivity.
rewrite <- (Z2Nat.id n) by lia.
induction (Z.to_nat n).
simpl; auto.
rewrite inj_S.
rewrite zeros_Zsucc by lia.
unfold intlist_to_bytelist; fold intlist_to_bytelist.
unfold Z.succ.
rewrite Z.add_comm.
rewrite Z.mul_add_distr_l.
replace (4 * 1 + 4 * Z.of_nat n0) with (Z.succ (Z.succ (Z.succ (Z.succ (4 * Z.of_nat n0))))) by lia.
repeat rewrite zeros_Zsucc by lia.
rewrite IHn0.
reflexivity.
Qed.

Definition padlen' (n: Z) : list Int.int :=
     let q := (n+8)/64*16 + 15 - (n+8)/4   (* number of zero-pad words *)
      in zeros q ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

Lemma padlen_eq: padlen=padlen'.
Proof.
extensionality n.
unfold padlen,padlen'; simpl.
f_equal. f_equal.
assert ((n+12)/4 = n/4+3).
intros.
replace (n+12) with (3*4+n) by lia.
 rewrite Z_div_plus_full_l by lia. lia.
rewrite <- H.
replace ((n+12)/4) with ((n+8)/4+1).
rewrite <- Z.add_assoc.
change (1+15) with (1*16).
rewrite <- (Z.add_comm (1*16)).
 rewrite Z_div_plus_full_l by lia.
rewrite Z.mul_add_distr_r.
rewrite Z.div_div by lia.
change (4*16) with 64.
lia.
replace (n+12) with (1*4+(n+8)) by lia.
 rewrite Z_div_plus_full_l by lia.
lia.
Qed.

Lemma length_generate_and_pad'':
  forall (l: list byte) (k: Z),
     k >= 0 ->
     k + Zlength (generate_and_pad' l (k*4)) = roundup (((k*4+Zlength l)+12)/4) 16.
Proof.
intro l.
remember (S (length l)) as L.
assert (length l < L)%nat by lia.
clear HeqL; revert l H; clear; induction L; intros.
inversion H.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen
  by (apply Z.le_ge; apply Z.mul_nonneg_nonneg; lia).
unfold Z.succ.
replace (k*4+0+12) with (k*4+4+8) by lia.
change 8 with (2*4).
rewrite Z_div_plus_full by lia.
replace ((k*4+4)/4)%Z with (k+1)%Z
 by (replace ((k*4+4)/4)%Z with (k*4/4 + 1)%Z
         by (symmetry; apply (Z_div_plus (k*4) 1 4); lia);
      rewrite Z_div_mult by lia; auto).
rewrite Z.sub_add.
rewrite Z.div_mul by congruence.
replace (k+1+2) with (k+3) by lia.
lia.
assert (k*4 >= 0).
apply Z.le_ge; apply Z.mul_nonneg_nonneg; lia.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen by lia.
unfold Z.succ. rewrite Z.sub_add.
replace (k*4+(0+1)+12) with (k*4+1+4+8) by lia.
change 8 with (2*4).
rewrite Z_div_plus_full by lia.
change (k * 4 + 1 + 4) with (k * 4 + 1 + 1*4).
rewrite (Z_div_plus (k*4+1) 1 4) by lia.
rewrite (Z.add_comm (k*4)).
rewrite Z_div_plus by lia.
change (1/4) with 0.
rewrite Z.add_0_l.
replace (k+1+2) with (k+3) by lia.
lia.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen by lia.
unfold Z.succ. rewrite Z.sub_add.
replace (k*4+(0+1+1)+12) with (k*4+2+4+8) by lia.
change 8 with (2*4).
rewrite Z_div_plus_full by lia.
change (k * 4 + 2 + 4) with (k * 4 + 2 + 1*4).
rewrite (Z_div_plus (k*4+2) 1 4) by lia.
rewrite (Z.add_comm (k*4)).
rewrite Z_div_plus by lia.
change (2/4) with 0.
rewrite Z.add_0_l.
replace (k+1+2) with (k+3) by lia.
lia.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen by lia.
unfold Z.succ. rewrite Z.sub_add.
replace (k*4+(0+1+1+1)+12) with (k*4+3+4+8) by lia.
change 8 with (2*4).
rewrite Z_div_plus_full by lia.
change (k * 4 + 3 + 4) with (k * 4 + 3 + 1*4).
rewrite (Z_div_plus (k*4+3) 1 4) by lia.
rewrite (Z.add_comm (k*4)).
rewrite Z_div_plus by lia.
change (3/4) with 0.
rewrite Z.add_0_l.
replace (k+1+2) with (k+3) by lia.
lia.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
unfold Z.succ.
transitivity (k+1 + (Zlength (generate_and_pad' l ((k+1) * 4)))).
rewrite Z.mul_add_distr_r.
change (1*4) with 4.
lia.
simpl in H.
rewrite IHL; try lia.
f_equal.
f_equal.
lia.
Qed.

Lemma length_generate_and_pad':
  forall (l: list byte),
     Zlength (generate_and_pad' l 0) = roundup ((Zlength l +12)/4) 16.
Proof.
intros.
transitivity (0 + Zlength (generate_and_pad' l (0*4))).
rewrite Z.add_0_l.
reflexivity.
apply length_generate_and_pad''.
lia.
Qed.

Lemma roundup_ge:
 forall a b,  b > 0 -> roundup a b >= a.
Proof.
intros.
assert (roundup a b - a >= 0); [ | lia].
rewrite roundup_minus by auto.
pose proof (Z.mod_pos_bound (-a) b); lia.
Qed.

Lemma generate_and_pad'_eq:
 generate_and_pad = generate_and_pad_alt.
Proof.
extensionality msg.
unfold generate_and_pad,  generate_and_pad_alt.
match goal with |- context [bytelist_to_intlist ?A] =>
  remember A as PADDED eqn:HP
end.
assert (Nat.divide 4 (length PADDED)). {
subst PADDED.
pose proof (roundup_ge (Zlength msg + 9) 64).
 spec H; [ lia | ].
assert (Zlength msg >= 0) by (rewrite Zlength_correct; lia).
exists (Z.to_nat (roundup (Zlength msg+9) 64 / 4 - 2)).
repeat rewrite app_length.
rewrite repeat_length.
simpl length.
symmetry.
transitivity (Z.to_nat (roundup (Zlength msg + 9) 64 / 4 - 2) * Z.to_nat 4)%nat; [reflexivity |].
rewrite <- Z2Nat.inj_mul; try lia.
2:{
assert (roundup (Zlength msg + 9) 64 / 4 >= (Zlength msg + 9) / 4)
 by (apply Z_div_ge; lia).
assert ((Zlength msg + 9) / 4 = (Zlength msg + 1)/4 + 2).
replace (Zlength msg + 9) with (Zlength msg + 1 + 2*4) by lia.
rewrite Z_div_plus_full by lia.
auto.
assert (0 <= (Zlength msg + 1)/4).
apply Z.div_pos;  lia.
lia. }
rewrite Z.mul_sub_distr_r.
replace (roundup (Zlength msg + 9) 64 / 4 * 4) with
  (roundup (Zlength msg + 9) 64).
2:{
unfold roundup.
forget ((Zlength msg + 9 + (64 - 1)) / 64 ) as N.
change 64 with (16 * 4).
rewrite Z.mul_assoc.
rewrite Z_div_mult_full by lia.
auto.
}
rewrite <- roundup_minus by lia.
change 64 with 64.
forget (roundup (Zlength msg + 9) 64) as N.
clear H0.
rewrite Zlength_correct in *.
forget (length msg) as L.
transitivity (Z.to_nat (Z.of_nat L + (1 + (N - (Z.of_nat L + 9))))).
f_equal. lia.
rewrite Z2Nat.inj_add  by lia.
rewrite Nat2Z.id.
f_equal.
rewrite Z2Nat.inj_add by lia.
f_equal.
}
remember (Z.to_nat (Zlength msg / 4)) as n.
change PADDED with (skipn 0 PADDED).
change msg with (skipn 0 msg) at 3.
change 0 with (Z.of_nat 0).
replace 0%nat with ((Z.to_nat (Zlength msg / 4) - n)*4)%nat
 by (rewrite Heqn, minus_diag; reflexivity).
assert (H88: (n * 4 <= length msg)%nat). {
 subst n.
 apply Nat2Z.inj_le.
 rewrite <- Zlength_correct. rewrite Nat2Z.inj_mul.
 rewrite Z2Nat.id.
 rewrite (Z_div_mod_eq (Zlength msg) 4) at 2 by lia.
 change (Z.of_nat 4) with 4. rewrite <- Z.mul_comm.
 pose proof (Z.mod_pos_bound (Zlength msg) 4); lia.
 apply Z.div_pos; try rewrite Zlength_correct; lia.
}
clear Heqn.
revert H88; induction n; intros.
* (* base case for n *)
clear H88.
rewrite Nat.sub_0_r.
rewrite Nat2Z.inj_mul.
assert (0 <= Zlength msg) by (rewrite Zlength_correct; lia).
assert (0 <= Zlength msg / 4) by (apply Z.div_pos; lia).
pose proof (Z_div_mod_eq (Zlength msg) 4). spec H2; [lia|].
assert (H99: (Z.to_nat (Zlength msg / 4) * 4 <= length msg)%nat).
apply Nat2Z.inj_le.
rewrite <- Zlength_correct.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id by auto.
change (Z.of_nat 4) with 4.
destruct (Z.mod_pos_bound (Zlength msg) 4); lia.
rewrite Z2Nat.id by lia.
change (Z.of_nat 4) with 4.
rewrite Z.mul_comm in H2.
assert (length (skipn (Z.to_nat (Zlength msg / 4) * 4) msg) < 4)%nat.
rewrite skipn_length.
apply Nat2Z.inj_lt.
rewrite Nat2Z.inj_sub. rewrite <- Zlength_correct.
rewrite Nat2Z.inj_mul. change (Z.of_nat 4) with 4.
rewrite Z2Nat.id by auto.
destruct (Z.mod_pos_bound (Zlength msg) 4); lia.
lia.
rewrite HP.
rewrite skipn_app1 by lia.
remember (skipn (Z.to_nat (Zlength msg / 4) * 4) msg) as ccc.
assert (HQ: (Zlength msg + 8) / 64 * 16 + 15 - (Zlength msg + 8) / 4 >= 0). {
clear - H0.
assert (0 <= Zlength msg + 8) by lia.
clear H0. forget (Zlength msg + 8) as a.
pose proof (Z_div_mod_eq a 64); spec H0; [lia|].
rewrite H0 at 2.
rewrite (Z.mul_comm 64).
change 64 with (16*4) at 3.
rewrite Z.mul_assoc.
rewrite Z_div_plus_full_l by lia.
assert (a mod 64 / 4 < 16).
apply Z.div_lt_upper_bound. lia. apply Z.mod_pos_bound; lia.
lia.
}
assert (- (Zlength msg + 9) mod 64 =
           (3 - Zlength ccc) + 4* ((Zlength msg+8)/64 * 16 + 15 - (Zlength msg + 8) / 4)). {
assert (LL: length ccc = length (skipn (Z.to_nat (Zlength msg / 4) * 4) msg))
 by congruence.
rewrite skipn_length in LL.
assert (LL': Zlength msg = Zlength ccc + (Zlength msg/4)*4).
rewrite Zlength_correct at 1.
rewrite Zlength_correct at 1.
 rewrite LL.
rewrite Nat2Z.inj_sub.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id by auto.
change (Z.of_nat 4) with 4; lia.
rewrite Nat2Z.inj_le.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id by auto.
rewrite <- Zlength_correct.
change (Z.of_nat 4) with 4.
assert (0 <= Zlength msg mod 4)
 by (apply Z.mod_pos_bound; lia).
lia.
replace (Zlength ccc) with (Zlength msg - Zlength msg / 4 * 4) by lia.
clear LL LL'.
clear - H0 HQ. forget (Zlength msg) as a.
 rewrite <- roundup_minus by lia; unfold roundup.
replace (a  + 9 + (64-1)) with (a + 8 + 1*64) by lia.
rewrite Z_div_plus_full by lia.
rewrite Z.mul_add_distr_r.
rewrite (Z.mul_comm 4).
rewrite Z.mul_sub_distr_r.
rewrite Z.mul_add_distr_r.
change (15*4) with (64-4).
rewrite <- Z.mul_assoc.
change (16*4) with 64.
assert (0 =8+ a / 4 * 4 - (a + 8) / 4 * 4);  [ | lia].
change 8 with (2*4) at 2.
rewrite Z_div_plus_full by lia.
rewrite Z.mul_add_distr_r.
lia.
}
rewrite H4.
assert (0 <= Zlength ccc < 4)
 by (clear - H3; rewrite Zlength_correct; lia).
rewrite Z2Nat.inj_add by lia.
rewrite repeat_app.
replace (Zlength msg / 4 * 4) with (Zlength msg - Zlength ccc).
2:{
rewrite Heqccc.
rewrite (Zlength_correct (skipn _ _)).
rewrite skipn_length by lia.
rewrite Nat2Z.inj_sub by lia.
rewrite <- Zlength_correct.
rewrite Nat2Z.inj_mul. change (Z.of_nat 4) with 4.
rewrite Z2Nat.id  by lia.
 lia.
}
match goal with |- context [_ ++ repeat Byte.zero (Z.to_nat (4 * ?qq))] =>
 assert (bytelist_to_intlist (repeat Byte.zero (Z.to_nat (4 * qq))) =
  zeros ((Zlength msg + 8) / 64 * 16 + 15 - (Zlength msg + 8) / 4));
  set (Q := qq) in *
end. {
 rewrite Z2Nat.inj_mul by lia. change (Z.to_nat 4) with 4%nat.
 rewrite <- Z2Nat.id at 2 by lia.
 induction (Z.to_nat Q). reflexivity.
 rewrite inj_S. rewrite zeros_equation.
 assert (0 < Z.succ (Z.of_nat n)) by lia.
 apply Z.gtb_lt in H6; rewrite H6.
 replace (Z.succ (Z.of_nat n) - 1) with (Z.of_nat n) by lia.
 rewrite <- IHn.
 replace (4 * S n)%nat with (S (S (S (S (4*n)))))%nat.
 reflexivity. lia.
}
set (Q4 := Z.to_nat (4 * Q)) in *.
destruct ccc as [|a [|b [|c [|]]]]; simpl in H3; try lia; clear H3;
 unfold generate_and_pad'; rewrite padlen_eq; unfold padlen';
 simpl;
repeat rewrite Zlength_cons; rewrite Zlength_nil.
+ (* ccc = [] *)
  rewrite Z.sub_0_r. rewrite H6. reflexivity.
+ (* ccc = [a] *)
   change (Z.succ 0) with 1; rewrite Z.sub_add. rewrite H6. reflexivity.
+ (* ccc = [a,b] *)
   change (Z.succ (Z.succ 0)) with 2; rewrite Z.sub_add.
   rewrite H6. reflexivity.
+ (* ccc = [a,b,c] *)
   change (Z.succ (Z.succ (Z.succ 0))) with 3; rewrite Z.sub_add.
   rewrite H6. reflexivity.
* (* inductive case for n *)
replace (S n * 4)%nat with (4 + n*4)%nat in H88 by lia.
assert ((Z.to_nat (Zlength msg / 4) - S n) * 4 = ((Z.to_nat (Zlength msg / 4) - n) * 4) - 4)%nat
  by lia.
rewrite H0. clear H0.
spec IHn; [lia |].
set (Q := ((Z.to_nat (Zlength msg / 4) - n) * 4)%nat) in *.
assert (Hyy : 0 <= Zlength msg) by (rewrite Zlength_correct; lia).
assert (Hzz:=Zmod_eq (Zlength msg) 4); spec Hzz; [lia|].
destruct (Z.mod_pos_bound (Zlength msg) 4); try  lia.
apply Nat2Z.inj_le in H88.
rewrite Nat2Z.inj_add, Nat2Z.inj_mul in H88.
rewrite <- Zlength_correct in H88.
change (Z.of_nat 4) with 4 in *.
assert (Huu:= Z.div_pos (Zlength msg) 4 Hyy); spec Huu; [lia|].
assert (Q >= 4)%nat. {
 clear - H88 Hyy Hzz H0 H1 Huu; unfold Q; clear Q.
apply Nat2Z.inj_ge. rewrite Nat2Z.inj_mul.
change (Z.of_nat 4) with 4 in *.
rewrite Nat2Z.inj_sub
 by (apply Nat2Z.inj_le; rewrite Z2Nat.id by auto;
       apply Zmult_le_reg_r with 4; lia).
 rewrite Z2Nat.id by auto.
change 4 with (1*4) at 3.
apply Zmult_ge_reg_r with 4; lia.
}
rewrite <- (firstn_skipn 4 (skipn (Q-4) PADDED)), skipn_drop.
rewrite <- (firstn_skipn 4 (skipn (Q-4) msg)), skipn_drop.
replace (4 + (Q-4))%nat with Q by lia.
rewrite HP at 1.
assert (QL: (Q <= length msg)%nat). {
apply Nat2Z.inj_le.
rewrite <- Zlength_correct.
unfold Q.
rewrite Nat2Z.inj_mul.
rewrite Nat2Z.inj_sub.
 rewrite Z2Nat.id by auto.
change (Z.of_nat 4) with 4 in *.
 rewrite Z.mul_sub_distr_r.
lia.
apply Nat2Z.inj_le.
 rewrite Z2Nat.id by auto.
lia.
}
rewrite skipn_app1 by lia.
rewrite firstn_app1
 by (rewrite skipn_length by lia; lia).
assert (length (firstn 4 (skipn (Q - 4) msg)) = 4)%nat.
rewrite firstn_length. rewrite skipn_length by lia.
apply min_l. lia.
destruct (firstn 4 (skipn (Q - 4) msg))
 as [ | z0 [| z1 [| z2 [|z3 [|]]]]];inv H3.
unfold app at 2. unfold app at 4.
unfold generate_and_pad'; fold generate_and_pad'.
unfold bytelist_to_intlist; fold bytelist_to_intlist.
replace (Z.of_nat (Q-4) + 4) with (Z.of_nat Q)
 by (rewrite Nat2Z.inj_sub by lia;
       change (Z.of_nat 4) with 4; lia).
rewrite <- IHn.
reflexivity.
Qed.

Lemma roundup_divide:
 forall a b, b > 0 ->  (b | roundup a b).
Proof.
intros.
unfold roundup.
apply Z.divide_factor_r.
Qed.

Lemma length_generate_and_pad:
  forall (l: list byte),
     Zlength (generate_and_pad l) = roundup ((Zlength l +12)/4) 16.
Proof.
intros.
rewrite generate_and_pad'_eq.
unfold generate_and_pad_alt.
apply length_generate_and_pad'.
Qed.

Transparent generate_word.

Lemma generate_word_lemma1:
  forall b n, length b = 16%nat ->
   firstn 16 (rev (generate_word (rev b) n)) = b.
Proof.
intros.
change (rev b) with (nil ++ rev b).
forget (@nil int) as a.
revert a; induction n; intro.
unfold generate_word.
rewrite rev_app_distr.
rewrite rev_involutive.
rewrite firstn_app1 by lia.
rewrite firstn_same; auto; lia.
unfold generate_word; fold generate_word.
change (Wnext (a ++ rev b) :: a ++ rev b) with
      ((Wnext (a ++ rev b) ::a) ++ rev b).
apply IHn.
Qed.

Lemma length_generate_word: forall b n,
  length (generate_word b n) = (length b + n)%nat.
Proof.
intros.
revert b; induction n; intros; simpl.
unfold generate_word; fold generate_word.
lia.
unfold generate_word; fold generate_word.
rewrite IHn.
simpl. lia.
Qed.

Lemma nth_generate_word_S:
  forall k i n b',
   nth (i+k) (generate_word b' (n+k)) = nth i (generate_word b' n).
Proof.
induction k; intros.
repeat rewrite plus_0_r. auto.
replace (n + S k)%nat with (S (n + k))%nat by lia.
unfold generate_word; fold generate_word.
replace (i + S k)%nat with (S i + k)%nat by lia.
rewrite IHk by (simpl; lia).
clear IHk.
revert i b' ; induction n; intros.
unfold generate_word; fold generate_word.
extensionality d; reflexivity.
unfold generate_word; fold generate_word.
apply IHn.
Qed.

Lemma generate_word_small:
  forall i b n,
           length b = 16%nat ->
           (i < length b)%nat ->
           nth i (rev (generate_word (rev b) n)) = nth i b.
Proof.
intros.
extensionality d.
rewrite <- (nth_firstn_low _ _ 16).
rewrite (generate_word_lemma1 b n H).
auto.
rewrite rev_length, length_generate_word, rev_length, H.
lia.
Qed.

Lemma generate_word_plus:
  forall msg a b, (16 <= length msg)%nat ->
         generate_word msg (a+b) = generate_word (generate_word msg a) b.
Proof.
intros msg a b.
revert msg b; induction a; simpl; intros.
unfold generate_word; fold generate_word.
auto.
unfold generate_word; fold generate_word.
rewrite IHa by (simpl; lia).
auto.
Qed.

Definition nthB (b: list int) (i: nat) (n: Z) :=
  nth (Z.to_nat (Z.of_nat i - 16 + n)) (rev (generate_word (rev b) 48)) Int.zero.

Lemma nth_rev_generate_word:
 forall i b,
   length b = 16%nat ->
   (16 <= i < 64)%nat ->
    nth i (rev (generate_word (rev b) 48)) Int.zero =
  Int.add (nthB b i 0)
    (Int.add (Int.add (sigma_0 (nthB b i 1)) (sigma_1 (nthB b i 14)))
       (nthB b i 9)).
Proof.
intros.
unfold nthB.
rewrite <- rev_length in H.
forget (rev b) as b'.
clear b.
assert (length (generate_word b' 48) = 64)%nat
 by (rewrite length_generate_word, H; reflexivity).
rewrite rev_nth by lia.
repeat rewrite rev_nth
 by (rewrite H1; change 64%nat with (Z.to_nat 64); apply Z2Nat.inj_lt; lia).
rewrite H1.
rewrite <- (plus_0_l (64 - S i)).
assert (48 = (i - 16) + 1 + (64 - S i))%nat by (clear - H0; lia).
rewrite H2 at 2.
rewrite nth_generate_word_S.
rewrite generate_word_plus by lia.
unfold generate_word at 1.
unfold nth at 1.
assert (forall n:nat, (n < 16) ->
    ((64 - S (Z.to_nat (Z.of_nat i - 16 + Z.of_nat n))) =
      (16-n) + (48 - S (Z.to_nat (Z.of_nat i - 16)))))%nat.
clear - H0.
intros.
rewrite Z2Nat.inj_add by lia.
rewrite Nat2Z.id.
rewrite Z2Nat.inj_sub by lia.
rewrite Nat2Z.id.
change (Z.to_nat 16) with 16%nat.
lia.
change 0%Z with (Z.of_nat 0); rewrite H3 by (clear; lia).
change 1%Z with (Z.of_nat 1); rewrite H3 by (clear; lia).
change 14%Z with (Z.of_nat 14); rewrite H3 by (clear; lia).
change 9%Z with (Z.of_nat 9); rewrite H3 by (clear; lia).
clear H3.
assert (48 = S (Z.to_nat (Z.of_nat i - 16)) + (48 - S (Z.to_nat (Z.of_nat i - 16))))%nat.
clear - H0.
rewrite Z2Nat.inj_sub by lia.
rewrite Nat2Z.id.
change (Z.to_nat 16) with 16%nat.
lia.
pattern (generate_word b' 48).
rewrite H3 at 1.
repeat rewrite nth_generate_word_S.
rewrite Z2Nat.inj_sub by lia.
rewrite Nat2Z.id.
change (Z.to_nat 16) with 16%nat.
simpl.
change (nth 16) with (@nth int (15+1)).
change (nth 15) with (@nth int (14+1)).
change (nth 2) with (@nth int (1+1)).
change (nth 7) with (@nth int (6+1)).
replace (S (i-16)) with ((i-16)+1)%nat by lia.
repeat rewrite nth_generate_word_S.
assert (length (generate_word b' (i-16)) >= 16)%nat.
rewrite length_generate_word, H; lia.
clear - H4.
forget (generate_word b' (i-16)) as s.
rename H4 into H.
do 16 (destruct s; [simpl in H; lia | ]).
simpl.
rewrite <- Int.add_assoc.
rewrite Int.add_commut.
f_equal.
rewrite Int.add_commut.
rewrite <- Int.add_assoc.
auto.
Qed.

Opaque generate_word.

Definition c48 := 48%nat. Opaque c48.

Lemma generate_word_W:
 forall block n
 (LB: length block = 16%nat),
  0 <= n < 64 ->
  nthi (rev (generate_word (rev block) 48)) n =
  W (nthi block) n.
Proof.
intros.
assert (forall i, (i <= Z.to_nat 64)%nat ->
              forall n, 0 <= n < Z.of_nat i ->
 nthi (rev (generate_word (rev block) 48)) n = W (nthi block) n).
2:{
apply (H0 (S (Z.to_nat n))).
apply Nat2Z.inj_le. rewrite inj_S.
repeat rewrite Z2Nat.id by lia. lia.
rewrite inj_S.
rewrite Z2Nat.id by lia. lia.
}
clear H n. induction i; intros.
change (Z.of_nat 0) with 0 in H0; lia.
spec IHi; [ lia | ].
unfold nthi at 1.
destruct (zlt n 16).
rewrite generate_word_small; auto.
2:{
rewrite LB.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by lia. apply l.
}
rewrite W_equation.
rewrite if_true by auto.
reflexivity.
rewrite nth_rev_generate_word; auto.
2: {
split.
apply Nat2Z.inj_le. change (Z.of_nat 16) with 16.
rewrite Z2Nat.id by lia. lia.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id by lia.
change (Z.of_nat 64) with 64.
apply Nat2Z.inj_le in H.
rewrite Z2Nat.id in H by lia.
lia.
}
rewrite W_equation.
rewrite if_false by lia.
rewrite inj_S in H0.
rewrite <- IHi by lia.
rewrite <- IHi by lia.
rewrite <- IHi by lia.
rewrite <- IHi by lia.
unfold nthB.
rewrite Z2Nat.id by lia.
replace (n - 16 + 14) with (n-2) by lia.
replace (n - 16 + 9) with (n - 7) by lia.
replace (n - 16 + 0) with (n-16) by lia.
replace (n - 16 + 1) with (n - 15) by lia.
unfold nthi.
forget (nth (Z.to_nat (n - 16)) (rev (generate_word (rev block) 48)) Int.zero)
  as A.
forget (sigma_1
        (nth (Z.to_nat (n - 2)) (rev (generate_word (rev block) 48)) Int.zero))
  as B.
forget  (sigma_0
           (nth (Z.to_nat (n - 15)) (rev (generate_word (rev block) 48))
              Int.zero))
  as C.
forget (nth (Z.to_nat (n - 7)) (rev (generate_word (rev block) 48)) Int.zero)
  as D.
rewrite Int.add_commut.
repeat rewrite <- Int.add_assoc.
f_equal.
rewrite <- (Int.add_commut D).
rewrite <- (Int.add_commut D).
rewrite Int.add_assoc.
f_equal.
apply Int.add_commut.
Qed.

Lemma process_block_hash_block:
 forall regs block,
   length regs = 8%nat ->
   length block = 16%nat ->
   process_block regs (rev block) = hash_block regs block.
Proof.
intros.
unfold process_block.
unfold hash_block.
f_equal.
rewrite <- (firstn_same _ 64 (rev (generate_word _ _)))
 by (rewrite rev_length, length_generate_word, rev_length; lia).
change 64%nat with (48+16)%nat.
change 63%Z with (Z.of_nat (48+16)-1).
assert (48 <= 48)%nat by lia.
remember 48%nat as n.
rewrite Heqn at 2.
rewrite Heqn in H1 at 2.
clear Heqn. rename H1 into H7.
revert regs H H7; induction n; intros.
simpl plus.
change 48%nat with c48 in H7 |- *.
remember 16%nat as n.
rewrite Heqn in H0.
assert (n <= 16)%nat by lia.
clear Heqn H7.
revert H1; induction n; intros.
* (* n=0 *)
simpl.
rewrite Round_equation.
rewrite if_true by lia.
reflexivity.
* (*0 < n <= 16 *)
rewrite Round_equation.
rewrite inj_S.
rewrite if_false by lia.
replace (Z.succ (Z.of_nat n) - 1) with (Z.of_nat n) by lia.
rewrite <- IHn by lia. clear IHn.
rewrite (rnd_64_S _ _ _
    (nthi K256 (Z.of_nat n))
    (nthi block (Z.of_nat n))).
2: (unfold nthi; rewrite Nat2Z.id; apply coqlib4.nth_error_nth; simpl; lia).
2:{
unfold nthi; rewrite Nat2Z.id.
rewrite (@coqlib4.nth_error_nth _ _ Int.zero n).
2: rewrite rev_length, length_generate_word, rev_length, H0;
  change c48 with 48%nat; lia.
f_equal.
rewrite generate_word_small by lia.
auto.
}
unfold rnd_function.
destruct (rnd_64 regs K256 (firstn n (rev (generate_word (rev block) c48))))
  as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; auto.
rewrite W_equation.
rewrite if_true; auto.
lia.
* (* 16 <= n < 64 *)
change (S n + 16)%nat with (S (n + 16)).
rewrite inj_S.
unfold Z.succ.
rewrite Z.add_simpl_r.
rewrite (rnd_64_S _ _ _
    (nthi K256 (Z.of_nat (n+16)))
    (nthi (rev (generate_word (rev block) c48)) (Z.of_nat (n+16)))).
2: (unfold nthi; rewrite Nat2Z.id; apply coqlib4.nth_error_nth; simpl; lia).
2:{
unfold nthi; rewrite Nat2Z.id.
apply (@coqlib4.nth_error_nth _ _ Int.zero (n+16)).
rewrite rev_length, length_generate_word, rev_length, H0;
  change c48 with 48%nat; lia.
}
rewrite Round_equation.
rewrite <- IHn by lia.
rewrite if_false by lia.
forget (rnd_64 regs K256 (firstn (n + 16) (rev (generate_word (rev block) 48))))
   as regs'.
unfold rnd_function.
destruct regs'
  as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; auto.
replace (W (nthi block) (Z.of_nat (n + 16)))
  with  (nthi (rev (generate_word (rev block) c48)) (Z.of_nat (n + 16)));
auto.
change c48 with 48%nat.
apply generate_word_W; auto.
rewrite Nat2Z.inj_add. change (Z.of_nat 16) with 16.
lia.
Qed.

Lemma process_msg_hash_blocks:
  forall regs blocks,
    (16 | Zlength blocks) ->
    length regs = 8%nat ->
    process_msg regs blocks = hash_blocks regs blocks.
Proof.
intros.
destruct H as [n ?].
rewrite Zlength_correct in H.
assert (0 <= n).
 apply Zmult_le_0_reg_r with 16; auto. lia.
 lia.
rewrite <- (Z2Nat.id n) in H by lia.
change 16 with (Z.of_nat 16) in H.
rewrite <- Nat2Z.inj_mul in H.
apply Nat2Z.inj in H.
clear H1.
revert blocks H regs H0; induction (Z.to_nat n); intros.
destruct blocks; inv H.
rewrite process_msg_equation, hash_blocks_equation.
reflexivity.
assert (length (firstn 16 blocks) = 16)%nat
 by (rewrite firstn_length, H; simpl; lia).
rewrite hash_blocks_equation.
destruct blocks; [ inv H | ].
forget (i::blocks) as bb.
clear n i blocks; rename bb into blocks.
rewrite <- (firstn_skipn 16 blocks) at 1.
rewrite process_msg_eq2 by auto.
rewrite process_block_hash_block; auto.
apply IHn0.
rewrite skipn_length; lia.
apply length_hash_block; auto.
Qed.

Lemma SHA_256'_eq:  SHA_256' = SHA_256.
Proof.
extensionality msg.
unfold SHA_256', SHA_256.
f_equal.
rewrite <- generate_and_pad'_eq.
assert (16 | Zlength (generate_and_pad msg)).
rewrite (length_generate_and_pad msg).
apply roundup_divide; lia.
assert (length init_registers = 8%nat) by reflexivity.
forget init_registers as regs.
forget (generate_and_pad msg) as blocks.
apply process_msg_hash_blocks; auto.
Qed.