(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Export Arith_base.
Require Import BinPos BinInt BinNat Pnat Nnat.

Local Open Scope Z_scope.

(** Conversions between integers and natural numbers

    Seven sections:
    - chains of conversions (combining two conversions)
    - module N2Z : from N to Z
    - module Z2N : from Z to N (negative numbers rounded to 0)
    - module Zabs2N : from Z to N (via the absolute value)
    - module Nat2Z : from nat to Z
    - module Z2Nat : from Z to nat (negative numbers rounded to 0)
    - module Zabs2Nat : from Z to nat (via the absolute value)
*)

(** * Chains of conversions *)

(** When combining successive conversions, we have the following
    commutative diagram:
<<
      ---> Nat ----
     |      ^      |
     |      |      v
    Pos ---------> Z
     |      |      ^
     |      v      |
      ----> N -----
>>
*)

Lemma nat_N_Z n : Z.of_N (N.of_nat n) = Z.of_nat n.
Proof.
 now destruct n.
Qed.

Lemma N_nat_Z n : Z.of_nat (N.to_nat n) = Z.of_N n.
Proof.
 destruct n; trivial. simpl.
 destruct (Pos2Nat.is_succ p) as (m,H).
 rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv.
Qed.

Lemma positive_nat_Z p : Z.of_nat (Pos.to_nat p) = Zpos p.
Proof.
 destruct (Pos2Nat.is_succ p) as (n,H).
 rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv.
Qed.

Lemma positive_N_Z p : Z.of_N (Npos p) = Zpos p.
Proof.
 reflexivity.
Qed.

Lemma positive_N_nat p : N.to_nat (Npos p) = Pos.to_nat p.
Proof.
 reflexivity.
Qed.

Lemma positive_nat_N p : N.of_nat (Pos.to_nat p) = Npos p.
Proof.
 destruct (Pos2Nat.is_succ p) as (n,H).
 rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv.
Qed.

Lemma Z_N_nat n : N.to_nat (Z.to_N n) = Z.to_nat n.
Proof.
 now destruct n.
Qed.

Lemma Z_nat_N n : N.of_nat (Z.to_nat n) = Z.to_N n.
Proof.
 destruct n; simpl; trivial. apply positive_nat_N.
Qed.

Lemma Zabs_N_nat n : N.to_nat (Z.abs_N n) = Z.abs_nat n.
Proof.
 now destruct n.
Qed.

Lemma Zabs_nat_N n : N.of_nat (Z.abs_nat n) = Z.abs_N n.
Proof.
 destruct n; simpl; trivial; apply positive_nat_N.
Qed.

(** * Conversions between [Z] and [N] *)

Module N2Z.

(** [Z.of_N] is a bijection between [N] and non-negative [Z],
    with [Z.to_N] (or [Z.abs_N]) as reciprocal.
    See [Z2N.id] below for the dual equation. *)

Lemma id n : Z.to_N (Z.of_N n) = n.
Proof.
 now destruct n.
Qed.

(** [Z.of_N] is hence injective *)

Lemma inj n m : Z.of_N n = Z.of_N m -> n = m.
Proof.
 destruct n, m; simpl; congruence.
Qed.

Lemma inj_iff n m : Z.of_N n = Z.of_N m <-> n = m.
Proof.
 split. apply inj. intros; now f_equal.
Qed.

(** [Z.of_N] produce non-negative integers *)

Lemma is_nonneg n : 0 <= Z.of_N n.
Proof.
 now destruct n.
Qed.

(** [Z.of_N], basic equations *)

Lemma inj_0 : Z.of_N 0 = 0.
Proof.
 reflexivity.
Qed.

Lemma inj_pos p : Z.of_N (Npos p) = Zpos p.
Proof.
 reflexivity.
Qed.

(** [Z.of_N] and usual operations. *)

Lemma inj_compare n m : (Z.of_N n ?= Z.of_N m) = (n ?= m)%N.
Proof.
 now destruct n, m.
Qed.

Lemma inj_le n m : (n<=m)%N <-> Z.of_N n <= Z.of_N m.
Proof.
 unfold Z.le. now rewrite inj_compare.
Qed.

Lemma inj_lt n m : (n<m)%N <-> Z.of_N n < Z.of_N m.
Proof.
 unfold Z.lt. now rewrite inj_compare.
Qed.

Lemma inj_ge n m : (n>=m)%N <-> Z.of_N n >= Z.of_N m.
Proof.
 unfold Z.ge. now rewrite inj_compare.
Qed.

Lemma inj_gt n m : (n>m)%N <-> Z.of_N n > Z.of_N m.
Proof.
 unfold Z.gt. now rewrite inj_compare.
Qed.

Lemma inj_abs_N z : Z.of_N (Z.abs_N z) = Z.abs z.
Proof.
 now destruct z.
Qed.

Lemma inj_add n m : Z.of_N (n+m) = Z.of_N n + Z.of_N m.
Proof.
 now destruct n, m.
Qed.

Lemma inj_mul n m : Z.of_N (n*m) = Z.of_N n * Z.of_N m.
Proof.
 now destruct n, m.
Qed.

Lemma inj_sub_max n m : Z.of_N (n-m) = Z.max 0 (Z.of_N n - Z.of_N m).
Proof.
 destruct n as [|n], m as [|m]; simpl; trivial.
 rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub.
 now destruct (Pos.sub_mask n m).
Qed.

Lemma inj_sub n m : (m<=n)%N -> Z.of_N (n-m) = Z.of_N n - Z.of_N m.
Proof.
 intros H. rewrite inj_sub_max.
 unfold N.le in H.
 rewrite N.compare_antisym, <- inj_compare, Z.compare_sub in H.
 destruct (Z.of_N n - Z.of_N m); trivial; now destruct H.
Qed.

Lemma inj_succ n : Z.of_N (N.succ n) = Z.succ (Z.of_N n).
Proof.
 destruct n. trivial. simpl. now rewrite Pos.add_1_r.
Qed.

Lemma inj_pred_max n : Z.of_N (N.pred n) = Z.max 0 (Z.pred (Z.of_N n)).
Proof.
 unfold Z.pred. now rewrite N.pred_sub, inj_sub_max.
Qed.

Lemma inj_pred n : (0<n)%N -> Z.of_N (N.pred n) = Z.pred (Z.of_N n).
Proof.
 intros H. unfold Z.pred. rewrite N.pred_sub, inj_sub; trivial.
 now apply N.le_succ_l in H.
Qed.

Lemma inj_min n m : Z.of_N (N.min n m) = Z.min (Z.of_N n) (Z.of_N m).
Proof.
 unfold Z.min, N.min. rewrite inj_compare. now case N.compare.
Qed.

Lemma inj_max n m : Z.of_N (N.max n m) = Z.max (Z.of_N n) (Z.of_N m).
Proof.
 unfold Z.max, N.max. rewrite inj_compare.
 case N.compare_spec; intros; subst; trivial.
Qed.

Lemma inj_div n m : Z.of_N (n/m) = Z.of_N n / Z.of_N m.
Proof.
 destruct m as [|m]. now destruct n.
 apply Z.div_unique_pos with (Z.of_N (n mod (Npos m))).
 split. apply is_nonneg. apply inj_lt. now apply N.mod_lt.
 rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod.
Qed.

Lemma inj_mod n m : (m<>0)%N -> Z.of_N (n mod m) = (Z.of_N n) mod (Z.of_N m).
Proof.
 intros Hm.
 apply Z.mod_unique_pos with (Z.of_N (n / m)).
 split. apply is_nonneg. apply inj_lt. now apply N.mod_lt.
 rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod.
Qed.

Lemma inj_quot n m : Z.of_N (n/m) = Z.of_N n ÷ Z.of_N m.
Proof.
 destruct m.
 - now destruct n.
 - rewrite Z.quot_div_nonneg, inj_div; trivial. apply is_nonneg. easy.
Qed.

Lemma inj_rem n m : Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m).
Proof.
 destruct m.
 - now destruct n.
 - rewrite Z.rem_mod_nonneg, inj_mod; trivial. easy. apply is_nonneg. easy.
Qed.

Lemma inj_div2 n : Z.of_N (N.div2 n) = Z.div2 (Z.of_N n).
Proof.
 destruct n as [|p]; trivial. now destruct p.
Qed.

Lemma inj_quot2 n : Z.of_N (N.div2 n) = Z.quot2 (Z.of_N n).
Proof.
 destruct n as [|p]; trivial. now destruct p.
Qed.

Lemma inj_pow n m : Z.of_N (n^m) = (Z.of_N n)^(Z.of_N m).
Proof.
 destruct n, m; trivial. now rewrite Z.pow_0_l. apply Pos2Z.inj_pow.
Qed.

Lemma inj_testbit a n :
 Z.testbit (Z.of_N a) (Z.of_N n) = N.testbit a n.
Proof. apply Z.testbit_of_N. Qed.

End N2Z.

Module Z2N.

(** [Z.to_N] is a bijection between non-negative [Z] and [N],
    with [Pos.of_N] as reciprocal.
    See [N2Z.id] above for the dual equation. *)

Lemma id n : 0<=n -> Z.of_N (Z.to_N n) = n.
Proof.
 destruct n; (now destruct 1) || trivial.
Qed.

(** [Z.to_N] is hence injective for non-negative integers. *)

Lemma inj n m : 0<=n -> 0<=m -> Z.to_N n = Z.to_N m -> n = m.
Proof.
 intros. rewrite <- (id n), <- (id m) by trivial. now f_equal.
Qed.

Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_N n = Z.to_N m <-> n = m).
Proof.
 intros. split. now apply inj. intros; now subst.
Qed.

(** [Z.to_N], basic equations *)

Lemma inj_0 : Z.to_N 0 = 0%N.
Proof.
 reflexivity.
Qed.

Lemma inj_pos n : Z.to_N (Zpos n) = Npos n.
Proof.
 reflexivity.
Qed.

Lemma inj_neg n : Z.to_N (Zneg n) = 0%N.
Proof.
 reflexivity.
Qed.

(** [Z.to_N] and operations *)

Lemma inj_add n m : 0<=n -> 0<=m -> Z.to_N (n+m) = (Z.to_N n + Z.to_N m)%N.
Proof.
 destruct n, m; trivial; (now destruct 1) || (now destruct 2).
Qed.

Lemma inj_mul n m : 0<=n -> 0<=m -> Z.to_N (n*m) = (Z.to_N n * Z.to_N m)%N.
Proof.
 destruct n, m; trivial; (now destruct 1) || (now destruct 2).
Qed.

Lemma inj_succ n : 0<=n -> Z.to_N (Z.succ n) = N.succ (Z.to_N n).
Proof.
 unfold Z.succ. intros. rewrite inj_add by easy. apply N.add_1_r.
Qed.

Lemma inj_sub n m : 0<=m -> Z.to_N (n - m) = (Z.to_N n - Z.to_N m)%N.
Proof.
 destruct n as [|n|n], m as [|m|m]; trivial; try (now destruct 1).
 intros _. simpl.
 rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub.
 now destruct (Pos.sub_mask n m).
Qed.

Lemma inj_pred n : Z.to_N (Z.pred n) = N.pred (Z.to_N n).
Proof.
 unfold Z.pred. rewrite <- N.sub_1_r. now apply (inj_sub n 1).
Qed.

Lemma inj_compare n m : 0<=n -> 0<=m ->
 (Z.to_N n ?= Z.to_N m)%N = (n ?= m).
Proof.
 intros Hn Hm. now rewrite <- N2Z.inj_compare, !id.
Qed.

Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_N n <= Z.to_N m)%N).
Proof.
 intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare.
Qed.

Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_N n < Z.to_N m)%N).
Proof.
 intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare.
Qed.

Lemma inj_min n m : Z.to_N (Z.min n m) = N.min (Z.to_N n) (Z.to_N m).
Proof.
 destruct n, m; simpl; trivial; unfold Z.min, N.min; simpl;
  now case Pos.compare.
Qed.

Lemma inj_max n m : Z.to_N (Z.max n m) = N.max (Z.to_N n) (Z.to_N m).
Proof.
 destruct n, m; simpl; trivial; unfold Z.max, N.max; simpl.
  case Pos.compare_spec; intros; subst; trivial.
  now case Pos.compare.
Qed.

Lemma inj_div n m : 0<=n -> 0<=m -> Z.to_N (n/m) = (Z.to_N n / Z.to_N m)%N.
Proof.
 destruct n, m; trivial; intros Hn Hm;
 (now destruct Hn) || (now destruct Hm) || clear.
 simpl. rewrite <- (N2Z.id (_ / _)). f_equal. now rewrite N2Z.inj_div.
Qed.

Lemma inj_mod n m : 0<=n -> 0<m ->
 Z.to_N (n mod m) = ((Z.to_N n) mod (Z.to_N m))%N.
Proof.
 destruct n, m; trivial; intros Hn Hm;
 (now destruct Hn) || (now destruct Hm) || clear.
 simpl. rewrite <- (N2Z.id (_ mod _)). f_equal. now rewrite N2Z.inj_mod.
Qed.

Lemma inj_quot n m : 0<=n -> 0<=m -> Z.to_N (n÷m) = (Z.to_N n / Z.to_N m)%N.
Proof.
 destruct m.
 - now destruct n.
 - intros. now rewrite Z.quot_div_nonneg, inj_div.
 - now destruct 2.
Qed.

Lemma inj_rem n m :0<=n -> 0<=m ->
 Z.to_N (Z.rem n m) = ((Z.to_N n) mod (Z.to_N m))%N.
Proof.
 destruct m.
 - now destruct n.
 - intros. now rewrite Z.rem_mod_nonneg, inj_mod.
 - now destruct 2.
Qed.

Lemma inj_div2 n : Z.to_N (Z.div2 n) = N.div2 (Z.to_N n).
Proof.
 destruct n as [|p|p]; trivial. now destruct p.
Qed.

Lemma inj_quot2 n : Z.to_N (Z.quot2 n) = N.div2 (Z.to_N n).
Proof.
 destruct n as [|p|p]; trivial; now destruct p.
Qed.

Lemma inj_pow n m : 0<=n -> 0<=m -> Z.to_N (n^m) = ((Z.to_N n)^(Z.to_N m))%N.
Proof.
 destruct m.
 - trivial.
 - intros. now rewrite <- (N2Z.id (_ ^ _)), N2Z.inj_pow, id.
 - now destruct 2.
Qed.

Lemma inj_testbit a n : 0<=n ->
 Z.testbit (Z.of_N a) n = N.testbit a (Z.to_N n).
Proof. apply Z.testbit_of_N'. Qed.

End Z2N.

Module Zabs2N.

(** Results about [Z.abs_N], converting absolute values of [Z] integers
    to [N]. *)

Lemma abs_N_spec n : Z.abs_N n = Z.to_N (Z.abs n).
Proof.
 now destruct n.
Qed.

Lemma abs_N_nonneg n : 0<=n -> Z.abs_N n = Z.to_N n.
Proof.
 destruct n; trivial; now destruct 1.
Qed.

Lemma id_abs n : Z.of_N (Z.abs_N n) = Z.abs n.
Proof.
 now destruct n.
Qed.

Lemma id n : Z.abs_N (Z.of_N n) = n.
Proof.
 now destruct n.
Qed.

(** [Z.abs_N], basic equations *)

Lemma inj_0 : Z.abs_N 0 = 0%N.
Proof.
 reflexivity.
Qed.

Lemma inj_pos p : Z.abs_N (Zpos p) = Npos p.
Proof.
 reflexivity.
Qed.

Lemma inj_neg p : Z.abs_N (Zneg p) = Npos p.
Proof.
 reflexivity.
Qed.

(** [Z.abs_N] and usual operations, with non-negative integers *)

Lemma inj_opp n : Z.abs_N (-n) = Z.abs_N n.
Proof.
 now destruct n.
Qed.

Lemma inj_succ n : 0<=n -> Z.abs_N (Z.succ n) = N.succ (Z.abs_N n).
Proof.
 intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_succ.
 now apply Z.le_le_succ_r.
Qed.

Lemma inj_add n m : 0<=n -> 0<=m -> Z.abs_N (n+m) = (Z.abs_N n + Z.abs_N m)%N.
Proof.
 intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_add.
 now apply Z.add_nonneg_nonneg.
Qed.

Lemma inj_mul n m : Z.abs_N (n*m) = (Z.abs_N n * Z.abs_N m)%N.
Proof.
 now destruct n, m.
Qed.

Lemma inj_sub n m : 0<=m<=n -> Z.abs_N (n-m) = (Z.abs_N n - Z.abs_N m)%N.
Proof.
 intros (Hn,H). rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_sub.
 Z.order.
 now apply Z.le_0_sub.
Qed.

Lemma inj_pred n : 0<n -> Z.abs_N (Z.pred n) = N.pred (Z.abs_N n).
Proof.
 intros. rewrite !abs_N_nonneg. now apply Z2N.inj_pred.
 Z.order.
 apply Z.lt_succ_r. now rewrite Z.succ_pred.
Qed.

Lemma inj_compare n m : 0<=n -> 0<=m ->
 (Z.abs_N n ?= Z.abs_N m)%N = (n ?= m).
Proof.
 intros. rewrite !abs_N_nonneg by trivial. now apply Z2N.inj_compare.
Qed.

Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_N n <= Z.abs_N m)%N).
Proof.
 intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare.
Qed.

Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_N n < Z.abs_N m)%N).
Proof.
 intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare.
Qed.

Lemma inj_min n m : 0<=n -> 0<=m ->
 Z.abs_N (Z.min n m) = N.min (Z.abs_N n) (Z.abs_N m).
Proof.
 intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_min.
 now apply Z.min_glb.
Qed.

Lemma inj_max n m : 0<=n -> 0<=m ->
 Z.abs_N (Z.max n m) = N.max (Z.abs_N n) (Z.abs_N m).
Proof.
 intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_max.
 transitivity n; trivial. apply Z.le_max_l.
Qed.

Lemma inj_quot n m : Z.abs_N (n÷m) = ((Z.abs_N n) / (Z.abs_N m))%N.
Proof.
 assert (forall p q, Z.abs_N (Zpos p ÷ Zpos q) = (Npos p / Npos q)%N).
  intros. rewrite abs_N_nonneg. now apply Z2N.inj_quot. now apply Z.quot_pos.
 destruct n, m; trivial; simpl.
 - trivial.
 - now rewrite <- Pos2Z.opp_pos, Z.quot_opp_r, inj_opp.
 - now rewrite <- Pos2Z.opp_pos, Z.quot_opp_l, inj_opp.
 - now rewrite <- 2 Pos2Z.opp_pos, Z.quot_opp_opp.
Qed.

Lemma inj_rem n m : Z.abs_N (Z.rem n m) = ((Z.abs_N n) mod (Z.abs_N m))%N.
Proof.
 assert
  (forall p q, Z.abs_N (Z.rem (Zpos p) (Zpos q)) = ((Npos p) mod (Npos q))%N).
  intros. rewrite abs_N_nonneg. now apply Z2N.inj_rem. now apply Z.rem_nonneg.
 destruct n, m; trivial; simpl.
 - trivial.
 - now rewrite <- Pos2Z.opp_pos, Z.rem_opp_r.
 - now rewrite <- Pos2Z.opp_pos, Z.rem_opp_l, inj_opp.
 - now rewrite <- 2 Pos2Z.opp_pos, Z.rem_opp_opp, inj_opp.
Qed.

Lemma inj_pow n m : 0<=m -> Z.abs_N (n^m) = ((Z.abs_N n)^(Z.abs_N m))%N.
Proof.
 intros Hm. rewrite abs_N_spec, Z.abs_pow, Z2N.inj_pow, <- abs_N_spec; trivial.
 f_equal. symmetry; now apply abs_N_nonneg. apply Z.abs_nonneg.
Qed.

(** [Z.abs_N] and usual operations, statements with [Z.abs] *)

Lemma inj_succ_abs n : Z.abs_N (Z.succ (Z.abs n)) = N.succ (Z.abs_N n).
Proof.
 destruct n; simpl; trivial; now rewrite Pos.add_1_r.
Qed.

Lemma inj_add_abs n m :
 Z.abs_N (Z.abs n + Z.abs m) = (Z.abs_N n + Z.abs_N m)%N.
Proof.
 now destruct n, m.
Qed.

Lemma inj_mul_abs n m :
 Z.abs_N (Z.abs n * Z.abs m) = (Z.abs_N n * Z.abs_N m)%N.
Proof.
 now destruct n, m.
Qed.

End Zabs2N.

(** * Conversions between [Z] and [nat] *)

Module Nat2Z.

(** [Z.of_nat], basic equations *)

Lemma inj_0 : Z.of_nat 0 = 0.
Proof.
 reflexivity.
Qed.

Lemma inj_succ n : Z.of_nat (S n) = Z.succ (Z.of_nat n).
Proof.
 destruct n. trivial. simpl. apply Pos2Z.inj_succ.
Qed.

(** [Z.of_N] produce non-negative integers *)

Lemma is_nonneg n : 0 <= Z.of_nat n.
Proof.
 now induction n.
Qed.

(** [Z.of_nat] is a bijection between [nat] and non-negative [Z],
    with [Z.to_nat] (or [Z.abs_nat]) as reciprocal.
    See [Z2Nat.id] below for the dual equation. *)

Lemma id n : Z.to_nat (Z.of_nat n) = n.
Proof.
 now rewrite <- nat_N_Z, <- Z_N_nat, N2Z.id, Nat2N.id.
Qed.

(** [Z.of_nat] is hence injective *)

Lemma inj n m : Z.of_nat n = Z.of_nat m -> n = m.
Proof.
 intros H. now rewrite <- (id n), <- (id m), H.
Qed.

Lemma inj_iff n m : Z.of_nat n = Z.of_nat m <-> n = m.
Proof.
 split. apply inj. intros; now f_equal.
Qed.

(** [Z.of_nat] and usual operations *)

Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = (n ?= m)%nat.
Proof.
 now rewrite <-!nat_N_Z, N2Z.inj_compare, <- Nat2N.inj_compare.
Qed.

Lemma inj_le n m : (n<=m)%nat <-> Z.of_nat n <= Z.of_nat m.
Proof.
 unfold Z.le. now rewrite inj_compare, nat_compare_le.
Qed.

Lemma inj_lt n m : (n<m)%nat <-> Z.of_nat n < Z.of_nat m.
Proof.
 unfold Z.lt. now rewrite inj_compare, nat_compare_lt.
Qed.

Lemma inj_ge n m : (n>=m)%nat <-> Z.of_nat n >= Z.of_nat m.
Proof.
 unfold Z.ge. now rewrite inj_compare, nat_compare_ge.
Qed.

Lemma inj_gt n m : (n>m)%nat <-> Z.of_nat n > Z.of_nat m.
Proof.
 unfold Z.gt. now rewrite inj_compare, nat_compare_gt.
Qed.

Lemma inj_abs_nat z : Z.of_nat (Z.abs_nat z) = Z.abs z.
Proof.
 destruct z; simpl; trivial;
  destruct (Pos2Nat.is_succ p) as (n,H); rewrite H; simpl; f_equal;
   now apply SuccNat2Pos.inv.
Qed.

Lemma inj_add n m : Z.of_nat (n+m) = Z.of_nat n + Z.of_nat m.
Proof.
 now rewrite <- !nat_N_Z, Nat2N.inj_add, N2Z.inj_add.
Qed.

Lemma inj_mul n m : Z.of_nat (n*m) = Z.of_nat n * Z.of_nat m.
Proof.
 now rewrite <- !nat_N_Z, Nat2N.inj_mul, N2Z.inj_mul.
Qed.

Lemma inj_sub_max n m : Z.of_nat (n-m) = Z.max 0 (Z.of_nat n - Z.of_nat m).
Proof.
 now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub_max.
Qed.

Lemma inj_sub n m : (m<=n)%nat -> Z.of_nat (n-m) = Z.of_nat n - Z.of_nat m.
Proof.
 rewrite nat_compare_le, Nat2N.inj_compare. intros.
 now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub.
Qed.

Lemma inj_pred_max n : Z.of_nat (Nat.pred n) = Z.max 0 (Z.pred (Z.of_nat n)).
Proof.
 now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max.
Qed.

Lemma inj_pred n : (0<n)%nat -> Z.of_nat (Nat.pred n) = Z.pred (Z.of_nat n).
Proof.
 rewrite nat_compare_lt, Nat2N.inj_compare. intros.
 now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred.
Qed.

Lemma inj_min n m : Z.of_nat (Nat.min n m) = Z.min (Z.of_nat n) (Z.of_nat m).
Proof.
 now rewrite <- !nat_N_Z, Nat2N.inj_min, N2Z.inj_min.
Qed.

Lemma inj_max n m : Z.of_nat (Nat.max n m) = Z.max (Z.of_nat n) (Z.of_nat m).
Proof.
 now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max.
Qed.

End Nat2Z.

Module Z2Nat.

(** [Z.to_nat] is a bijection between non-negative [Z] and [nat],
    with [Pos.of_nat] as reciprocal.
    See [nat2Z.id] above for the dual equation. *)

Lemma id n : 0<=n -> Z.of_nat (Z.to_nat n) = n.
Proof.
 intros. now rewrite <- Z_N_nat, <- nat_N_Z, N2Nat.id, Z2N.id.
Qed.

(** [Z.to_nat] is hence injective for non-negative integers. *)

Lemma inj n m : 0<=n -> 0<=m -> Z.to_nat n = Z.to_nat m -> n = m.
Proof.
 intros. rewrite <- (id n), <- (id m) by trivial. now f_equal.
Qed.

Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_nat n = Z.to_nat m <-> n = m).
Proof.
 intros. split. now apply inj. intros; now subst.
Qed.

(** [Z.to_nat], basic equations *)

Lemma inj_0 : Z.to_nat 0 = O.
Proof.
 reflexivity.
Qed.

Lemma inj_pos n : Z.to_nat (Zpos n) = Pos.to_nat n.
Proof.
 reflexivity.
Qed.

Lemma inj_neg n : Z.to_nat (Zneg n) = O.
Proof.
 reflexivity.
Qed.

(** [Z.to_nat] and operations *)

Lemma inj_add n m : 0<=n -> 0<=m ->
 Z.to_nat (n+m) = (Z.to_nat n + Z.to_nat m)%nat.
Proof.
 intros. now rewrite <- !Z_N_nat, Z2N.inj_add, N2Nat.inj_add.
Qed.

Lemma inj_mul n m : 0<=n -> 0<=m ->
 Z.to_nat (n*m) = (Z.to_nat n * Z.to_nat m)%nat.
Proof.
 intros. now rewrite <- !Z_N_nat, Z2N.inj_mul, N2Nat.inj_mul.
Qed.

Lemma inj_succ n : 0<=n -> Z.to_nat (Z.succ n) = S (Z.to_nat n).
Proof.
 intros. now rewrite <- !Z_N_nat, Z2N.inj_succ, N2Nat.inj_succ.
Qed.

Lemma inj_sub n m : 0<=m -> Z.to_nat (n - m) = (Z.to_nat n - Z.to_nat m)%nat.
Proof.
 intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub.
Qed.

Lemma inj_pred n : Z.to_nat (Z.pred n) = Nat.pred (Z.to_nat n).
Proof.
 now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred.
Qed.

Lemma inj_compare n m : 0<=n -> 0<=m ->
 (Z.to_nat n ?= Z.to_nat m)%nat = (n ?= m).
Proof.
 intros Hn Hm. now rewrite <- Nat2Z.inj_compare, !id.
Qed.

Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_nat n <= Z.to_nat m)%nat).
Proof.
 intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare.
Qed.

Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_nat n < Z.to_nat m)%nat).
Proof.
 intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
Qed.

Lemma inj_min n m : Z.to_nat (Z.min n m) = Nat.min (Z.to_nat n) (Z.to_nat m).
Proof.
 now rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min.
Qed.

Lemma inj_max n m : Z.to_nat (Z.max n m) = Nat.max (Z.to_nat n) (Z.to_nat m).
Proof.
 now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max.
Qed.

End Z2Nat.

Module Zabs2Nat.

(** Results about [Z.abs_nat], converting absolute values of [Z] integers
    to [nat]. *)

Lemma abs_nat_spec n : Z.abs_nat n = Z.to_nat (Z.abs n).
Proof.
 now destruct n.
Qed.

Lemma abs_nat_nonneg n : 0<=n -> Z.abs_nat n = Z.to_nat n.
Proof.
 destruct n; trivial; now destruct 1.
Qed.

Lemma id_abs n : Z.of_nat (Z.abs_nat n) = Z.abs n.
Proof.
 rewrite <-Zabs_N_nat, N_nat_Z. apply Zabs2N.id_abs.
Qed.

Lemma id n : Z.abs_nat (Z.of_nat n) = n.
Proof.
 now rewrite <-Zabs_N_nat, <-nat_N_Z, Zabs2N.id, Nat2N.id.
Qed.

(** [Z.abs_nat], basic equations *)

Lemma inj_0 : Z.abs_nat 0 = 0%nat.
Proof.
 reflexivity.
Qed.

Lemma inj_pos p : Z.abs_nat (Zpos p) = Pos.to_nat p.
Proof.
 reflexivity.
Qed.

Lemma inj_neg p : Z.abs_nat (Zneg p) = Pos.to_nat p.
Proof.
 reflexivity.
Qed.

(** [Z.abs_nat] and usual operations, with non-negative integers *)

Lemma inj_succ n : 0<=n -> Z.abs_nat (Z.succ n) = S (Z.abs_nat n).
Proof.
 intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ, N2Nat.inj_succ.
Qed.

Lemma inj_add n m : 0<=n -> 0<=m ->
 Z.abs_nat (n+m) = (Z.abs_nat n + Z.abs_nat m)%nat.
Proof.
 intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_add, N2Nat.inj_add.
Qed.

Lemma inj_mul n m : Z.abs_nat (n*m) = (Z.abs_nat n * Z.abs_nat m)%nat.
Proof.
 destruct n, m; simpl; trivial using Pos2Nat.inj_mul.
Qed.

Lemma inj_sub n m : 0<=m<=n ->
 Z.abs_nat (n-m) = (Z.abs_nat n - Z.abs_nat m)%nat.
Proof.
 intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_sub, N2Nat.inj_sub.
Qed.

Lemma inj_pred n : 0<n -> Z.abs_nat (Z.pred n) = Nat.pred (Z.abs_nat n).
Proof.
 intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_pred, N2Nat.inj_pred.
Qed.

Lemma inj_compare n m : 0<=n -> 0<=m ->
 (Z.abs_nat n ?= Z.abs_nat m)%nat = (n ?= m).
Proof.
 intros. now rewrite <- !Zabs_N_nat, <- N2Nat.inj_compare, Zabs2N.inj_compare.
Qed.

Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_nat n <= Z.abs_nat m)%nat).
Proof.
 intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare.
Qed.

Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_nat n < Z.abs_nat m)%nat).
Proof.
 intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
Qed.

Lemma inj_min n m : 0<=n -> 0<=m ->
 Z.abs_nat (Z.min n m) = Nat.min (Z.abs_nat n) (Z.abs_nat m).
Proof.
 intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_min, N2Nat.inj_min.
Qed.

Lemma inj_max n m : 0<=n -> 0<=m ->
 Z.abs_nat (Z.max n m) = Nat.max (Z.abs_nat n) (Z.abs_nat m).
Proof.
 intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max.
Qed.

(** [Z.abs_nat] and usual operations, statements with [Z.abs] *)

Lemma inj_succ_abs n : Z.abs_nat (Z.succ (Z.abs n)) = S (Z.abs_nat n).
Proof.
 now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ_abs, N2Nat.inj_succ.
Qed.

Lemma inj_add_abs n m :
 Z.abs_nat (Z.abs n + Z.abs m) = (Z.abs_nat n + Z.abs_nat m)%nat.
Proof.
 now rewrite <- !Zabs_N_nat, Zabs2N.inj_add_abs, N2Nat.inj_add.
Qed.

Lemma inj_mul_abs n m :
 Z.abs_nat (Z.abs n * Z.abs m) = (Z.abs_nat n * Z.abs_nat m)%nat.
Proof.
 now rewrite <- !Zabs_N_nat, Zabs2N.inj_mul_abs, N2Nat.inj_mul.
Qed.

End Zabs2Nat.

(** Compatibility *)

Definition neq (x y:nat) := x <> y.

Lemma inj_neq n m : neq n m -> Zne (Z.of_nat n) (Z.of_nat m).
Proof. intros H H'. now apply H, Nat2Z.inj. Qed.

Lemma Zpos_P_of_succ_nat n : Zpos (Pos.of_succ_nat n) = Z.succ (Z.of_nat n).
Proof (Nat2Z.inj_succ n).

(** For these one, used in omega, a Definition is necessary *)

Definition inj_eq := (f_equal Z.of_nat).
Definition inj_le n m := proj1 (Nat2Z.inj_le n m).
Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m).
Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m).
Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m).

(** For the others, a Notation is fine *)

Notation inj_0 := Nat2Z.inj_0 (only parsing).
Notation inj_S := Nat2Z.inj_succ (only parsing).
Notation inj_compare := Nat2Z.inj_compare (only parsing).
Notation inj_eq_rev := Nat2Z.inj (only parsing).
Notation inj_eq_iff := (fun n m => iff_sym (Nat2Z.inj_iff n m)) (only parsing).
Notation inj_le_iff := Nat2Z.inj_le (only parsing).
Notation inj_lt_iff := Nat2Z.inj_lt (only parsing).
Notation inj_ge_iff := Nat2Z.inj_ge (only parsing).
Notation inj_gt_iff := Nat2Z.inj_gt (only parsing).
Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (only parsing).
Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (only parsing).
Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (only parsing).
Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (only parsing).
Notation inj_plus := Nat2Z.inj_add (only parsing).
Notation inj_mult := Nat2Z.inj_mul (only parsing).
Notation inj_minus1 := Nat2Z.inj_sub (only parsing).
Notation inj_minus := Nat2Z.inj_sub_max (only parsing).
Notation inj_min := Nat2Z.inj_min (only parsing).
Notation inj_max := Nat2Z.inj_max (only parsing).

Notation Z_of_nat_of_P := positive_nat_Z (only parsing).
Notation Zpos_eq_Z_of_nat_o_nat_of_P :=
  (fun p => eq_sym (positive_nat_Z p)) (only parsing).

Notation Z_of_nat_of_N := N_nat_Z (only parsing).
Notation Z_of_N_of_nat := nat_N_Z (only parsing).

Notation Z_of_N_eq := (f_equal Z.of_N) (only parsing).
Notation Z_of_N_eq_rev := N2Z.inj (only parsing).
Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (only parsing).
Notation Z_of_N_compare := N2Z.inj_compare (only parsing).
Notation Z_of_N_le_iff := N2Z.inj_le (only parsing).
Notation Z_of_N_lt_iff := N2Z.inj_lt (only parsing).
Notation Z_of_N_ge_iff := N2Z.inj_ge (only parsing).
Notation Z_of_N_gt_iff := N2Z.inj_gt (only parsing).
Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (only parsing).
Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (only parsing).
Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (only parsing).
Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (only parsing).
Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (only parsing).
Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (only parsing).
Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (only parsing).
Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (only parsing).
Notation Z_of_N_pos := N2Z.inj_pos (only parsing).
Notation Z_of_N_abs := N2Z.inj_abs_N (only parsing).
Notation Z_of_N_le_0 := N2Z.is_nonneg (only parsing).
Notation Z_of_N_plus := N2Z.inj_add (only parsing).
Notation Z_of_N_mult := N2Z.inj_mul (only parsing).
Notation Z_of_N_minus := N2Z.inj_sub_max (only parsing).
Notation Z_of_N_succ := N2Z.inj_succ (only parsing).
Notation Z_of_N_min := N2Z.inj_min (only parsing).
Notation Z_of_N_max := N2Z.inj_max (only parsing).
Notation Zabs_of_N := Zabs2N.id (only parsing).
Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (only parsing).
Notation Zabs_N_succ := Zabs2N.inj_succ (only parsing).
Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (only parsing).
Notation Zabs_N_plus := Zabs2N.inj_add (only parsing).
Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (only parsing).
Notation Zabs_N_mult := Zabs2N.inj_mul (only parsing).

Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z.of_nat (n - m) = 0.
Proof.
 intros. rewrite not_le_minus_0; auto with arith.
Qed.


Require Import Arith.
Require Import List.

(*
Require Import Peano.
Require Import Peano_dec.
*)

Inductive Ty : Set :=
| TV : nat -> Ty
| Imp : Ty -> Ty -> Ty
| All : Ty -> Ty.

Lemma ty_eq_dec : forall (ty1 ty2 : Ty), {ty1 = ty2} + {ty1 <> ty2}.
Proof.
  decide equality. decide equality.
Defined.

Inductive Term : Set :=
| V : nat -> Term
| App : Term -> Term -> Term
| TApp : Term -> Ty -> Term
| Abs : Ty -> Term -> Term
| Lam : Term -> Term.

Inductive Ctx : Set :=
| G : nat -> list Ty -> Ctx.

Inductive Holds : Set :=
| H : Ctx -> Term -> Ty -> Holds.

Notation "n ; l |= t @ ty" := (H (G n l) t ty) (at level 60).
Open Scope list_scope.

Fixpoint tyshift (ty : Ty) (d : nat) {struct ty} : Ty :=
  match ty with
    | TV m => if le_lt_dec d m then TV (S m) else TV m
    | Imp t s => Imp (tyshift t d) (tyshift s d)
    | All t => All (tyshift t (S d))
  end.

Require Import Omega.
Definition tysub : forall (ty : Ty) (n : nat) (s : Ty), Ty.
Proof.
  refine
    (fix tysub (ty : Ty) (n : nat) (s : Ty) {struct ty} : Ty :=
      match ty with
        | TV m => match le_lt_dec n m with
                    | left p => match eq_nat_dec n m with
                                  | left _ => s
                                  | right p' =>
                                    (match m as m' return (m = m' -> Ty) with
                                      | 0 => (fun p'' => False_rec _ _)
                                      | S m' => (fun _ => TV m')
                                     end) (refl_equal m)
                                end
                    | right _ => TV m
                  end
        | Imp ty1 ty2 => Imp (tysub ty1 n s) (tysub ty2 n s)
        | All t => All (tysub t (S n) (tyshift s n))
      end).
  destruct m. apply le_n_O_eq in p. apply p'. auto. inversion p''.
Defined.

Print tysub.

Fixpoint tysubt (t : Term) (n : nat) (s : Ty) {struct t} : Term :=
  match t with
    | V m => V m
    | Abs ty t => Abs (tysub ty n s) (tysubt t n s)
    | Lam t => Lam (tysubt t (S n) s)
    | App f g => App (tysubt f n s) (tysubt g n s)
    | TApp f ty => TApp (tysubt f n s) (tysub ty n s)
  end.

Fixpoint valid (ty : Ty) (n : nat) {struct ty} : Prop :=
  match ty with
    | TV m =>
      if le_lt_dec n m
        then False
        else True
    | Imp s t => valid s n /\ valid t n
    | All t => valid t (S n)
  end.

Definition valid_dec : forall (ty : Ty) (n : nat), {valid ty n}+{~ valid ty n}.
Proof.
  induction ty ; intros.
  (* TV *)
  case_eq (le_lt_dec n0 n). intros. right. simpl. rewrite H0. auto.
  intros. left. simpl. rewrite H0. auto.
  (* Imp *)
  simpl.
  (* All *)
  firstorder.
Defined.

Print valid_dec.

 Lemma tyshift_level : forall ty1 n,
   valid ty1 n -> valid (tyshift ty1 n) (S n).
 Proof.
   induction ty1.
   (* TV *)
   intros. simpl.
   case_eq (le_lt_dec n0 n). simpl. intros. rewrite H1.
   simpl in H0. rewrite H1 in H0. inversion H0.
   intros. simpl. destruct n. auto.
   case_eq (le_lt_dec n0 n). intros. simpl. omega. simpl. intros. auto.
   (* Imp *)
   intros. simpl in H0.  inversion H0.
   simpl. auto.
   (* All *)
   intros. simpl in H0. simpl. apply IHty1. auto.
 Defined.

 Lemma tysub_level : forall ty1 ty2 n,
   valid ty1 (S n) -> valid ty2 n -> valid (tysub ty1 n ty2) n.
 Proof.
   induction ty1. intros.
   (* TV *)
   simpl.
   case_eq (le_lt_dec n0 n); case_eq (eq_nat_dec n0 n) ; intros ; auto.
   destruct n. absurd (n0 <> 0). omega. omega.
   simpl in H0. case_eq (le_lt_dec n0 n). intros. rewrite H4 in H0. simpl in H0. inversion H0.
   intros. clear H0.  absurd (n0 <> S n). intros. omega. omega.
   absurd (n0 = n). omega. omega. simpl. rewrite H3. auto.
   (* Imp *)
   intros. simpl in H0. inversion H0. simpl. split. auto. auto.
   (* All *)
   intros. simpl in H0. simpl.
   apply IHty1. auto.
   (* need tyshift lemma *)
   apply tyshift_level. auto.
 Defined.

 Definition Zero := (All (TV 0)).
 Definition One := (Imp Zero Zero).

 Inductive Derivation : Holds -> Set :=
 | ImpIntro : forall n l t ty xty,
   valid xty n ->
   Derivation (n ; l |= t @ ty) ->
   Derivation (n ; xty::l |= (Abs xty t) @ (Imp xty ty))
 | ImpElim : forall n l t f ty xty,
   Derivation (n ; l |= t @ xty) ->
   Derivation (n ; l |= f @ (Imp xty ty)) ->
   Derivation (n ; l |= (App f t) @ ty)
 | AllIntro : forall n l t ty,
   Derivation (S n ; l |= t @ ty) ->
   Derivation (n ; l |= (Lam t) @ All ty)
 | AllElim : forall n l t ty xty,
   Derivation (n ; l |= (TApp t xty) @ ty) ->
   Derivation (S n ; l |= t @ (tysub ty n xty))
 | VarIntro : forall n l ty i,
   i < length l -> nth i l Zero = ty ->
   Derivation (n ; l |= V i @ ty)
 | Weaken : forall n l t ty ty',
   valid ty' n ->
   Derivation (n ; l |= t @ ty) ->
   Derivation (n ; (l++(ty'::nil)) |= t @ ty)
 | WeakenTy : forall n l t ty,
   Derivation (n ; l |= t @ ty) ->
   Derivation (S n ; l |= t @ ty).

 Fixpoint typeof (n : nat) (l : list Ty) (t : Term) {struct t} : option Ty :=
   match t with
     | V n' =>
       if le_lt_dec (length l) n'
         then None
         else Some (nth n' l Zero)
     | App r s =>
       (fun mrty msty =>
         match mrty,msty with
           | Some (Imp xty yty),Some xty' =>
             if ty_eq_dec xty' xty
               then Some yty
               else None
           | _,_ => None
         end) (typeof n l r) (typeof n l s)
     | TApp r ty =>
       (fun mrty =>
         match mrty with
           | Some (All ty') => Some (tysub ty' n ty)
           | _ => None
         end) (typeof n l r)
     | Abs ty r =>
       (fun mrty =>
         match mrty with
           | Some ty' => Some (Imp ty ty')
           | _ => None
         end) (typeof n (ty::l) r)
     | Lam r =>
       (fun mrty =>
         match mrty with
           | Some ty' => Some (All ty')
           | _ => None
         end) (typeof (S n) l r)
  end.

Eval compute in typeof 0 nil (Lam (Abs (TV 3) (V 0))).

Definition check : forall n l t ty, option (Derivation (n ; l |= t @ ty)).
Proof.
  refine
    (fix check (n : nat) (l : list Ty) (t : Term) (ty : Ty) {struct t} : option (Derivation (n ; l |= t @ ty)) :=
      (match t as t' return t = t' -> option (Derivation (n ; l |= t @ ty)) with
         | V n' => match le_lt_dec (length l) n' with
                     | left p => (fun _ => None (A:=Derivation (n; l |= t @ ty)))
                     | right p =>
                       match ty_eq_dec (nth n' l Zero) ty with
                         | left p' => _
                         | right p' => (fun _ => None (A:=Derivation (n; l |= t @ ty)))
                       end
                   end
         | App r s => (fun r' s' => _) (check n l r (Imp tyx ty)) (check n l s tyx)
         | Abs ty' s => _
         | TApp r ty' => _
         | Lam s => _
       end) (refl_equal t)).
  (* V -- using firstorder as a stand-in for failure *)
  intros. apply Some. apply (VarIntro n l ty) in p.  rewrite <- H0 in p. auto. auto. intros.
  (* App *)
  apply (check n l r

Defined.
Print check.


(* Choice functions *)

From intuitionism Require Import lib set seq spr fan func.

(* Choice on finite domains. *)
Section FiniteChoice.

(* Choice with an upper bound in nat *)
Theorem bounded_choice {W} N (P : nat -> W -> Prop) (inhabitant : W) :
  (∀n, n < N -> ∃m, P n m) -> ∃f, ∀n, n < N -> P n (f n).
Proof.
intros H; induction N. now exists (λ _, inhabitant).
destruct IHN as [f Hf]. intros; apply H; auto.
destruct (H N) as [m Hm]; auto.
exists (λ n, if n =? N then m else f n); intros n Hn.
inversion_clear Hn. now rewrite eqb_refl.
replace (n =? N) with false by bool_lia. apply Hf; auto.
Qed.

(* bounded_choice with nat as witness *)
Corollary bounded_choice_nat N (P : nat -> nat -> Prop) :
  (∀n, n < N -> ∃m, P n m) -> ∃f, ∀n, n < N -> P n (f n).
Proof. apply bounded_choice. apply 0. Qed.

(* Choice for lists *)
Section ListChoice.

Variable W : Type.
Variable inhabitant : W.

Section GenericList.

Variable T : Type.
Variable P : T -> W -> Prop.
Variable eq_T : T -> T -> bool.
Variable eq_T_ext : ∀x y, eq_T x y = true <-> x = y.

Theorem list_choice s :
  (∀x, In x s -> ∃w, P x w) -> ∃f, ∀x, In x s -> P x (f x).
Proof.
intros H; induction s. now exists (λ _, inhabitant).
destruct IHs as [f Hf]. intros x Hx. apply H; now right.
destruct (H a) as [w Hw]. apply in_eq.
exists (λ x, if eq_T a x then w else f x); intros x Hx.
inversion_clear Hx. apply eq_T_ext in H0 as R; subst; now rewrite R.
destruct (eq_T a x) eqn:E. apply eq_T_ext in E. now subst. auto.
Qed.

End GenericList.

(* Choice for finite sequences *)
Corollary fseq_choice (P : nat -> W -> Prop) (s : fseq) :
  (∀n, In n s -> ∃w, P n w) -> ∃f, ∀n, In n s -> P n (f n).
Proof. apply list_choice with (eq_T:=eqb). split; intros; bool_lia. Qed.

(* Choice for lists of finite sequences *)
Corollary fseq_list_choice (P : fseq -> W -> Prop) (b : list fseq) :
  (∀s, In s b -> ∃w, P s w) -> ∃f, ∀s, In s b -> P s (f s).
Proof.
apply list_choice with (eq_T:=list_beq _ eqb). split; intros.
- apply internal_list_dec_bl with (eq_A:=eqb); auto. intros; bool_lia.
- apply internal_list_dec_lb with (eq_A:=eqb); auto. intros; bool_lia.
Qed.

End ListChoice.
End FiniteChoice.

(* Unprovable choice statements. *)

(* Choice on countable sets. *)
Section CountableChoice.

Definition AC_00 := ∀(R : nat -> nat -> Prop),
  (∀m, ∃n, R m n) -> ∃f, ∀m, R m (f m).

Definition AC_01 := ∀(R : nat -> seq -> Prop),
  (∀n, ∃α, R n α) -> ∃f, ∀n, R n (f n).

End CountableChoice.

(*
We first define an encoding for a continuous choice function f : seq -> nat such
that f is itself continuous.
*)
Section ContinuousChoiceFunction.

Inductive cfun_answer := CFContinue | CFDecide (n : nat).
Record cfun := CFun {
  cfun_σ : fseq -> cfun_answer;
  cfun_terminate : ∀α, ∃n, cfun_σ ⟨α;n⟩ <> CFContinue;
}.

Variable φ : cfun.
Variable α : seq.

Lemma answer_dec :
  ∀n, {cfun_σ φ ⟨α;n⟩ <> CFContinue} + {~(cfun_σ φ ⟨α;n⟩ <> CFContinue)}.
Proof. intros; destruct (cfun_σ φ ⟨α;n⟩). now right. now left. Qed.

Definition cfun_time := epsilon_smallest _ answer_dec (cfun_terminate φ α).
Definition cfun_compute :=
  let n := proj1_sig cfun_time in
  match cfun_σ φ ⟨α;n⟩ with
  | CFDecide k => k
  | CFContinue => 0
  end.

End ContinuousChoiceFunction.

Notation "φ '∣' α" := (cfun_compute φ α) (at level 50, format "φ '∣' α").

Lemma cfun_eqn φ α :
  ∃m, ∀β, eqn m α β -> φ∣α = φ∣β.
Proof.
unfold cfun_compute. destruct (cfun_time φ α) as [Nα [H1 H2]]; simpl.
exists Nα; intros. destruct (cfun_time φ β) as [Nβ [H3 H4]]; simpl.
apply eqn_eq_get in H. replace Nβ with Nα. now rewrite H.
apply eq_dne; intros E. apply not_eq in E as [E|E].
- assert(Hα := H4 Nα); rewrite <-H in Hα. apply Hα in H1. lia.
- apply eqn_eq_get in H. apply eqn_le with (m:=Nβ) in H. apply eqn_eq_get in H.
  assert(Hβ := H2 Nβ); rewrite H in Hβ. apply Hβ in H3. lia. lia.
Qed.

(* Choice on continuous sets. *)
Section ContinuousChoice.

Definition AC_10 := ∀(R : seq -> nat -> Prop),
  (∀α, ∃n, R α n) -> ∃φ, ∀α, R α (φ∣α).

Definition AC_11 := ∀(R : seq -> seq -> Prop),
  (∀α, ∃β, R α β) -> ∃Φ, ∀α, R α (λ n, Φ n∣α).

(* AC_11 has a controversial implication. *)
Theorem AC_11_controversy :
  AC_11 -> ~∀α, ∃β, (∀n : nat, α n = 0) <-> ∃n : nat, β n <> 0.
Proof.
intros AC H. apply AC in H as [Φ HΦ].
destruct (proj1 (HΦ (0^ω))) as [n Hn]. easy.
destruct (cfun_eqn (Φ n) (0^ω)) as [m Hm].
pose(β := pre m (0^ω) (1^ω)). assert(Hβ : eqn m (0^ω) β) by apply eqn_pre_n.
apply Hm in Hβ. assert(H: ∃n, Φ n∣β <> 0) by (exists n; lia).
eapply HΦ with(n:=m) in H. unfold β in H.
rewrite pre_r0 in H. discriminate.
Qed.

End ContinuousChoice.


Set Universe Polymorphism.

(* To avoid dependencies with the hott library, we will not
   prove some technical lemmas, and admit them *)
Axiom admit : forall X, X.
Ltac cheat := apply admit.

(* Definition of dependent sums and projections, with notations *)

Inductive sigT {A:Type} (P:A -> Type) : Type :=
    existT : forall x:A, P x -> sigT P.

Definition projT1 {A} {P:A -> Type} (x:sigT P) : A := match x with
                                      | existT _ a _ => a
                                      end.

Definition projT2  {A} {P:A -> Type} (x:sigT P) : P (projT1 x) :=
  match x return P (projT1 x) with
  | existT _ _ h => h
  end.

Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).

(* identity function and composition *)

Notation id := (fun x => x).

Notation compose := (fun g f x => g (f x)).

Notation "g ∘ f" := (compose g%function f%function) (at level 1): function_scope.

(* Definition of equality *)

Inductive I (A : Type) (x : A) : A -> Type :=
  refl : I A x x.

Arguments refl {_} _.

Notation "x = y" := (I _ x y): type_scope.

Definition subst (A:Type) (t:A) (P : forall y:A, t = y -> Type)
           (u : A) (p : t = u) (v:P t (refl t)) : P u p :=
  match p with
  | refl _ => v (* : P t (refl t) *)
  end.

(* Check computation behaviour of subst *)

Section subst_computation.

  Variable A : Type.
  Variable t : A.
  Variable P : forall y:A, t = y -> Type.
  Variable v : P t (refl t).

  Eval cbn in
      subst A t P t (refl t) v.

End subst_computation.

(* Some omega-groupoid laws on equality *)

Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  destruct p; exact q.
Defined.

Notation "p @ q" := (concat p q) (at level 20).

Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
    := match p with refl _ => refl _ end.

Notation "p ^" := (inverse p) (at level 3, format "p '^'").

Notation "f == g" := (forall x, f x = g x) (at level 3).

Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
  : f == g
  := fun x => match h with refl _ => refl _  end.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with refl _ => u end.

Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).

Definition concat_p1 A (x y :A) (e: x = y) : e @ refl _ = e.
Proof.
  destruct e; reflexivity.
Defined.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with refl _ => refl _ end.

Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) :
  ap f (p^) = (ap f p)^.
Proof.
  destruct p; reflexivity.
Defined.

Definition concat_Vp {A : Type} {x y : A} (p : x = y) : p^ @ p = refl _.
  destruct p; reflexivity.
Defined.

Definition concat_pV {A : Type} {x y : A} (p : x = y) : p @ p^ = refl _.
  destruct p; reflexivity.
Defined.

Definition inv2 A (x y :A) (e: x = y) : e^ ^= e.
Proof.
  destruct e; reflexivity.
Defined.

Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) :
  ap f (p @ q) = (ap f p) @ (ap f q).
  destruct p; reflexivity.
Defined.

Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) :
  refl _ = p^ @ q -> p = q.
Proof.
  destruct p. exact id.
Defined.

Definition concat_1p {A : Type} {x y : A} (p : x = y) :
  refl _ @ p = p := refl _.

Definition moveL_M1 {A : Type} {x y : A} (p q : x = y) :
  refl _ = q @ p^ -> p = q.
Proof.
  destruct p.
  intro h. exact (h @ (concat_p1 _ _ _  _)).
Defined.

Definition moveL_M1' {A : Type} {x y : A} (p q : x = y) :
  q^ @ p = refl _ -> p = q.
Proof.
  destruct p. intro e. rewrite concat_p1 in e.
  rewrite <- inv2. rewrite e. reflexivity.
Defined.

Definition moveR_transport_V {A : Type} (P : A -> Type) {x y : A}
  (p : y = x) (u : P x) (v : P y)
  : u = p # v -> p^ # u = v.
Proof.
  destruct p.
  exact id.
Defined.

Definition moveR_transport_p {A : Type} (P : A -> Type) {x y : A}
  (p : x = y) (u : P x) (v : P y)
  : u = p^ # v -> p # u = v.
Proof.
  destruct p.
  exact id.
Defined.

Definition concat_A1p {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) :
  (ap f q) @ (p y) = (p x) @ q.
  destruct q. cbn. apply inverse. apply concat_p1.
Defined.

Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) :
  r @ q = p -> r = p @ q ^.
Proof.
  destruct r. cbn in *. destruct 1. destruct q. reflexivity.
Defined.

Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  p @ (q @ r) = (p @ q) @ r.
  destruct p, q; reflexivity.
Defined.

Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
  ap (g ∘ f) p = ap g (ap f p).
  destruct p. reflexivity. Defined.

Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) :
  (p x) @ (ap f q) =  q @ (p y).
  destruct q; simpl. apply concat_p1.
Defined.

Definition ap2 {A A' B:Type} (f:A -> A' -> B) {x y:A} (p:x = y)
  {x' y':A'} (q:x' = y') : f x x' = f y y'
  := match p with refl _ => match q with refl _ => refl _ end end.

Definition transport_paths_Fl {A B : Type} {f g : A -> B} {x1 x2 : A}
  (p : x1 = x2) (q : f x1 = g x1)
  : transport (fun x => f x = g x) p q = (ap f p)^ @ q @ (ap g p).
Proof.
  destruct p. cbn. apply inverse. apply concat_p1.
Defined.

Definition concat_V A (x y z:A) (e:x=y) (e' : y = z) : (e @ e')^ =
                                                       e' ^@ e ^.
destruct e, e'; reflexivity.
Defined.

(* Structure of equality on dependent sums *)

Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : {x:A & P x})
           (pq : {p : u.1 = v.1 & u.2 = p^# v.2})
: u = v.
Proof.
  destruct pq as [p q].
  destruct u as [u1 u2], v as [v1 v2]. cbn in p. cbn in q.
  destruct p. cbn in q.
  destruct q. exact  (refl (u1;u2)).
Defined.

Definition pr1_path {A} `{P : A -> Type} {u v : sigT P} (p : u = v) : u.1 = v.1 := ap projT1 p.

Notation "p ..1" := (pr1_path p) (at level 50).

Definition pr2_path {A} `{P : A -> Type} {u v : sigT P} (p : u = v)
  : u.2 = p..1^ # v.2.
  destruct p. reflexivity.
Defined.

Notation "p ..2" := (pr2_path p) (at level 50).

(* Structure of equality on dependent sums *)

(* How transport acts on ap *)

Definition transport_ap {A B : Type} (P : B -> Type) (f : A -> B) {x y : A}
           (p : x = y) (z : P (f x)) : transport P (ap f p) z =
                                       transport (fun x => P (f x)) p z.
Proof.
  destruct p; reflexivity.
Defined.

(* How transport acts on arrows *)

Definition transport_arrow {A : Type} {B C : A -> Type}
  {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C x1) (y : B x2)
  : (transport (fun x => B x -> C x) p f) y  =  p # (f (p^ # y)).
Proof.
  destruct p. reflexivity.
Defined.

(* How transport acts on equality type *)

Definition transport_paths_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y)
  : transport (fun x => x = y) p q = p^ @ q.
Proof.
  destruct p, q; reflexivity.
Defined.

Definition transport_paths_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1)
  : transport (fun y => x = y) p q = q @ p.
Proof.
  destruct p. apply (concat_p1 _ _ _ _)^.
Defined.

(* Definition of equivalences *)

Class IsEquiv {A : Type} {B : Type} (f : A -> B) := BuildIsEquiv {
  e_inv :> B -> A ;
  e_sect : forall x, e_inv (f x) = x;
  e_retr : forall y, f (e_inv y) = y;
  e_adj : forall x : A, e_retr (f x) = ap f (e_sect x);
}.

Arguments e_inv {_ _} _ {_} _.
Arguments e_sect {_ _} _ {_} _.
Arguments e_retr {_ _} _ {_} _.
Arguments e_adj {_ _} _ {_} _.

Class Equiv A B := BuildEquiv {
  e_fun :> A -> B ;
  e_isequiv :> IsEquiv e_fun
}.

Notation "A ≃ B" := (Equiv A B) (at level 20).

Arguments e_fun {_ _} _ _.
Arguments e_isequiv {_ _ _}.

Typeclasses Transparent e_fun e_inv.

Coercion e_fun : Equiv >-> Funclass.

(* other adjunction coherence from e_adj *)
Theorem other_adj A B (f:A->B) {H : IsEquiv f} (b : B):
  e_sect f (IsEquiv := H) (e_inv f b) = ap (e_inv f) (e_retr f b).
Proof.
  cheat.
Defined.

(* The inverse of an equivalence is an equivalence *)

Instance isequiv_inverse A B (f:A->B) {H : IsEquiv f} : IsEquiv (e_inv f)
    := BuildIsEquiv _ _ (e_inv f) f (e_retr f) (e_sect f) (other_adj _ _ _).

Definition Equiv_inverse {A B : Type} (e: A ≃ B) : B ≃ A := BuildEquiv _ _ (e_inv (e_fun e)) (isequiv_inverse _ _ _).

Typeclasses Transparent e_fun e_inv.

(* ap is an equivalence *)

Definition ap_inv_equiv {A B} (f : A -> B) `{IsEquiv _ _ f} x y : f x = f y -> x = y.
Proof.
  intro X. exact ((e_sect f x)^@ ap (e_inv f) X @ e_sect f y).
Defined.

Definition ap_inv_equiv' {A B} (f : A -> B) `{IsEquiv _ _ f} x y : e_inv f x = e_inv f y -> x = y.
Proof.
  intro X. exact ((e_retr f x)^@ ap f X @ e_retr f y).
Defined.

Definition ap_id A (x y:A) (e:x = y) : ap id e = e.
Proof.
  destruct e; reflexivity.
Defined.

Instance IsEquiv_ap_transport A (P : A -> Type) {x y : A} (p : x = y) (u v : P x)
  : IsEquiv (@ap _ _ (fun (X : P x) => p # X) u v).
Proof.
  unshelve econstructor; cbn.
  - intros. destruct p. exact X.
  - intro e. destruct p. cbn. apply ap_id.
  - intro e. destruct p. cbn. apply ap_id.
  - intro e; destruct e. destruct p. reflexivity.
Defined.

(* can be found in theories/Basics/Equivalences.v *)

Instance isequiv_ap A B {x y : A} (f:A->B) {H:IsEquiv f}
  : IsEquiv (@ap _ _ f x y).
Proof.
  unshelve econstructor; cbn.
  - apply ap_inv_equiv. auto.
  - intro e. destruct e. unfold ap_inv_equiv. cbn. rewrite concat_p1.
    apply concat_Vp.
  - cheat.
  - cheat.
Defined.

(* functional extensionality axiom *)

Definition Funext := forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g).

(* Level of homotopy of types *)

Definition IsContr (A:Type) := { x : A & forall y, x = y}.
Existing Class IsContr.

Fixpoint IsTrunc n A := match n with
                           | O => IsContr A
                           | S n => forall x y:A, IsTrunc n (x = y)
                           end.

Definition IsHProp A := IsTrunc 1 A.

(* begin contractible is the lowest level of truncation *)

Definition path_contr {A} `{IsContrA : IsContr A} (x y : A) : x = y
  := let contr := IsContrA.2 in (contr x)^ @ (contr y).

Definition path2_contr {A} `{IsContr A} {x y : A} (p q : x = y) : p = q.
Proof.
  assert (K : forall (r : x = y), r = path_contr x y).
  intro r; destruct r. unfold path_contr.
  symmetry. apply concat_Vp.
  transitivity (path_contr x y). apply K. symmetry; apply
                                                      K.
Defined.

Definition contr_paths_contr A `{IsContr A} (x y : A) : IsContr (x = y).
  unshelve econstructor.
  exact (path_contr x y).
  exact (path2_contr _).
Defined.

(* begin proof irrelevant is the same as IsHprop *)

Definition IsIrr A := forall x y : A, x = y.

Definition IsIrr_inhab_IsContr A (H: IsIrr A) : A -> IsContr A :=
  fun x => existT _ x (H x).

Definition IsHProp_to_IsIrr A : IsHProp A -> IsIrr A :=
  fun H x y => (H x y).1.

Definition IsIrr_to_IsHProp A : IsIrr A -> IsHProp A.
  unshelve econstructor.
  apply X.
  intro e. unshelve eapply path2_contr. apply IsIrr_inhab_IsContr; auto.
Defined.

Definition IsHProp_inhab_isContr A {H:A -> IsContr A} : IsHProp A.
  apply IsIrr_to_IsHProp. intros x y.
  exact (@path_contr _ (H x) _ _).
Defined.

(* Singleton types are contractible*)

Definition singleton A (x:A) := {y : A & x = y}.

Definition singleton_IsContr A x : IsContr (singleton A x).
Proof.
  unshelve econstructor.
  unfold singleton. exists x. apply refl.
  intros [y e].
  apply path_sigma_uncurried. cbn. exists e.
   symmetry. eapply concat. apply (transport_paths_r e^ e).
      apply concat_pV.
Defined.

(* Preservation of homotopy level *)

Definition contr_equiv A B (f : A -> B)
  `{IsContr A} `{IsEquiv A B f}
  : IsContr B.
Proof.
  unshelve econstructor.
  - exact (f H.1).
  - intro b. eapply concat; try exact (e_retr f b).
    apply ap. apply H.2.
Defined.

Definition trunc_equiv n A B (f : A -> B)
  `{IsTrunc n A} `{IsEquiv A B f}
  : IsTrunc n B.
Proof.
  generalize dependent B; generalize dependent A.
  induction n; cbn ; intros.
  - apply (contr_equiv A B f).
  - unshelve eapply (IHn ((e_inv f x = e_inv f y)) _ (x = y)).
    + apply IsTrunc0.
    + apply ap_inv_equiv. apply isequiv_inverse.
    + exact (@isequiv_inverse _ _ (ap (e_inv f)) (isequiv_ap B A (e_inv f))).
Defined.

Definition IsTrunc_Forall {funext:Funext} A (B : A -> Type) n
           (H : forall x, IsTrunc n (B x)) : IsTrunc n (forall x, B x).
Proof.
  revert A B H. induction n; intros.
  - unshelve econstructor.
    + intro a. apply (H a).1.
    + intro f. apply funext. intro a. apply (H a).2.
  - intros f g. cbn in H. unshelve eapply (trunc_equiv _ _ _ (e_inv (apD10))).
    + auto.
    + apply IHn. cbn in H. intro a. exact (H a (f a) (g a)).
    + apply isequiv_inverse.
Defined.

(* IsTrunc is a mere proposition *)

Definition IsHProp_IsTrunc n A {funext : Funext} :
  IsHProp (IsTrunc n A).
Proof.
  apply IsIrr_to_IsHProp. revert A.
  induction n; cbn in *; intros A H H'.
  - apply path_sigma_uncurried.  unshelve econstructor.
    exact (H.2 (H'.1)).
    apply funext. intro x. unshelve eapply path2_contr.
  - apply funext. intro x. apply funext. intro y.
    exact (IHn (x = y) (H x y) (H' x y)).
Defined.

(* Adjunctification of an isomorphism *)

Definition e_inv' {A B : Type} (e : A ≃ B) : B -> A := e_inv (e_fun e).
Definition e_sect' {A B : Type} (e : A ≃ B) := e_sect (e_fun e).
Definition e_retr' {A B : Type} (e : A ≃ B) := e_retr (e_fun e).
Definition e_adj' {A B : Type} (e : A ≃ B) := e_adj (e_fun e).

Definition issect'  {A B : Type} (f : A -> B) (g : B -> A)
           (issect : g ∘ f == id) (isretr : f  ∘ g == id) :=
  fun x =>
    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.

Definition is_adjoint' {A B : Type} (f : A -> B) (g : B -> A)
           (issect : g∘ f == id) (isretr : f  ∘ g == id) (a : A) : isretr (f a) = ap f (issect' f g issect isretr a).
Proof.
  unfold issect'.
  apply moveL_M1.
  repeat rewrite ap_pp. rewrite <- concat_p_pp; rewrite <- ap_compose.
  pose  (concat_pA1 (fun b => (isretr b)^) (ap f (issect a))). cbn in i.
  eapply concat. Focus 2. apply ap2. reflexivity. exact i. cbn. clear i.
  rewrite <- concat_p_pp.
  pose (concat_A1p (fun b => (isretr b)) (isretr (f a))). cbn in i.
  apply moveL_Vp in i.
  rewrite <- concat_p_pp in i. rewrite concat_pV in i.
  rewrite concat_p1 in i.
  rewrite ap_compose in i.
  eapply concat. Focus 2. apply ap2. reflexivity.
  rewrite concat_p_pp. eapply concat. Focus 2.
  apply ap2. eapply concat. Focus 2.
  apply ap2. symmetry. apply i. reflexivity.
  symmetry. apply concat_pV. reflexivity. reflexivity.
  repeat rewrite <- ap_compose. cbn.
  cbn. symmetry. eapply concat. refine (ap_pp ((f ∘ g) ∘f) _ _)^.
  rewrite concat_Vp. reflexivity.
Defined.

Definition isequiv_adjointify {A B : Type} (f : A -> B) (g : B -> A)
           (issect : g∘ f == id) (isretr : f  ∘ g == id)  : IsEquiv f
  := BuildIsEquiv A B f g (issect' f g issect isretr) isretr
                  (is_adjoint' f g issect isretr).

(* homotopy fiber *)

Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.

Definition hfiber_canonical {A B : Type} (f : A -> B) (x : A) : hfiber f (f x)
  := (x ; refl _).

(* Isequiv f <-> forall y, IsContr (hfiber f y) *)

Definition IsEquiv_hfiber_IsContr {A B : Type} (f : A -> B) :
  IsEquiv f -> forall y, IsContr (hfiber f y).
Proof.
  intros H y. unshelve econstructor.
  - exists (e_inv f y). exact (e_retr f y).
  - intros [x e]. apply path_sigma_uncurried. unshelve econstructor; cbn.
    + destruct e. exact (e_sect f x).
    + destruct e. rewrite <- (transport_ap (fun X => X = f x) f).
      rewrite (e_adj f). rewrite transport_paths_l. rewrite concat_p1.
      repeat rewrite ap_V. apply (inv2 _ _ _ _)^.
Defined.

Definition hfiber_IsEquiv_IsContr {A B : Type} (f : A -> B) :
  (forall y, IsContr (hfiber f y)) -> IsEquiv f.
Proof.
  intros fib.
  unshelve econstructor.
  - intro y. exact (fib y).1.1.
  - intro x. cbn.
    pose ((fib (f x)).2).  cbn in i.
    pose ((i (hfiber_canonical f x))..1). exact i0.
  - intro y. cbn. apply (fib y).1.2.
  - intro x. cbn.
    pose ((fib (f x)).2 (hfiber_canonical f x)..2). cbn in i.
    eapply concat; try exact i. rewrite <- (transport_ap (fun X => X = f x) f).
    rewrite transport_paths_l. rewrite concat_p1.
    repeat rewrite ap_V. apply (inv2 _ _ _ _).
Defined.

(* beign an equivalence is HProp (not finished) *)

Definition IsEquiv_compose {funext:Funext} {A B C: Type} (f : A -> B) (H:IsEquiv f)
           : IsEquiv (fun (g:C -> A) => f ∘ g).
Proof.
  simple refine (isequiv_adjointify _ _ _ _).
  - exact (fun g => (e_inv f) ∘ g).
  - cbn. intro g. apply funext. intro b. apply e_sect.
  - cbn. intro g. apply funext. intro a. apply e_retr.
Defined.

Definition rinv {A B : Type} (f : A -> B) := {g:B->A & f ∘ g = id}.

Definition rinv_IsContr {funext:Funext} {A B : Type} (f : A -> B) (H:IsEquiv f)
  : IsContr (rinv f).
Proof.
  apply IsEquiv_hfiber_IsContr. unshelve eapply IsEquiv_compose; auto.
Defined.

Definition rcoh {A B : Type} (f : A -> B) (H:rinv f) :=
  {eta: H.1 ∘ f = id & forall x:A, apD10 H.2 _  = ap f (apD10 eta x) }.

Definition rcoh_IsContr {funext:Funext} {A B : Type} (f : A -> B) (H:IsEquiv f) (Hrinv:rinv f)
  : IsContr (rcoh f Hrinv).
Proof.
  cheat.
Defined.

(* Equivalences between dependent products *)

Definition functor_forall {A B} `{P : A -> Type} `{Q : B -> Type}
    (f : B -> A) (g : forall b:B, P (f b) -> Q b)
  : (forall a:A, P a) -> (forall b:B, Q b) := fun H b => g b (H (f b)).

Instance isequiv_functor_forall {funext : Funext} {A B} {P : A -> Type} {Q : B -> Type}
         (f : B -> A) `{!IsEquiv f} (g : forall b, P (f b) -> Q b) `{!forall b, IsEquiv (g b)}
  : IsEquiv (functor_forall f g).
Proof.
  simple refine (isequiv_adjointify _ _ _ _).
  - refine (functor_forall (e_inv f) _).
    intros a y. generalize (e_inv (g _) y).
    exact (transport P (e_retr f a)).
  - intros h. apply funext. intro a. unfold functor_forall.
    destruct (e_retr f a). cbn. apply e_sect.
  - intros h;apply funext. unfold functor_forall. intros b.
    rewrite e_adj. destruct (e_sect f b).
    cbn. apply e_retr.
Defined.

Instance Equiv_forall (A A' : Type)  (B : A -> Type) (B' : A' -> Type)
         (eA : A ≃ A') (eB : forall x, B (e_inv eA x) ≃ B' x )
         {funext : Funext}
         : (forall x:A , B x) ≃ (forall x:A', B' x).
Proof.
  unshelve refine (BuildEquiv _ _ (functor_forall (e_inv eA) (fun x => e_fun (eB x))) _).
  unshelve eapply isequiv_functor_forall. auto. apply isequiv_inverse.
  intro a'. exact (@e_isequiv _ _ (eB a')).
Defined.

(* Equivalences between dependent sums *)

Fixpoint sigma_map {A B P Q} (f: A -> B) (g : forall a, P a -> Q (f a)) (l : sigT P) : sigT Q :=
  match l with
  | existT _ a l => existT _ (f a) (g a l)
  end.

Definition sigma_map_compose {A B C P Q R } (f: A -> B) (f' : B -> C)
           (g : forall a, P a -> Q (f a)) (g' : forall b, Q b -> R (f' b))
           (l : sigT P):
  sigma_map f' g' (sigma_map f g l) = sigma_map (f' ∘ f) (fun a l => g' (f a) (g a l)) l.
Proof.
  destruct l; reflexivity.
Defined.

Definition sigma_map_eq {A P} (f: A -> A) (g : forall a, P a -> P (f a))
           (H : forall x, f x = x) (H' : forall a (l : P a), (H a)^ # l = g a l) (l : sigT P) :
 sigma_map f g l = l.
Proof.
  induction l. apply path_sigma_uncurried. unshelve econstructor; cbn; auto.
  symmetry. apply H'.
Defined.

Definition naturality'  {A B} `{P : A -> Type} `{Q : B -> Type}
           (f : A -> B)
           (e' : forall a, P a -> Q (f a)) a b (e : a = b) z:
  transport (Q ∘ f) e (e' _ z) = e' _ (e # z).
Proof.
  destruct e. reflexivity.
Defined.

Definition Equiv_Sigma (A A':Type) (B: A -> Type) (B': A' -> Type)
           (eA: A ≃ A') (eB : forall x, B x ≃ B' (e_fun eA x) ) :
  (sigT B) ≃ (sigT B').
Proof.
  unshelve refine (BuildEquiv _ _ _ (isequiv_adjointify _ _ _ _)).
  - unshelve refine (sigma_map eA (fun x => e_fun (eB x))).
  - pose (sigma_map (e_inv eA) (fun a => e_inv (eB (e_inv eA a)))).
    intro x. apply s. exists x.1.
    apply (transport B' (e_retr eA _)^). exact x.2.
  - intros [a b]. cbn. apply path_sigma_uncurried.
    unshelve econstructor; cbn. apply e_sect.
    rewrite e_adj. rewrite <- ap_V, transport_ap.
    rewrite (naturality' (e_fun eA) eB).
    apply e_sect.
  - intros [a b].
    cbn. apply path_sigma_uncurried. cbn.
    unshelve econstructor; apply e_retr.
Defined.

Definition transport_pV {A : Type} (P : A -> Type) {x y : A} (p : x = y) (z : P y)
  : p # p^ # z = z.
  destruct p. reflexivity.
Defined.

Definition transport_Vp {A : Type} (P : A -> Type) {x y : A} (p : x = y) (z : P x)
  : p^ # p # z = z.
  destruct p. reflexivity.
Defined.

Instance isequiv_path {A B : Type} (p : A = B)
  : IsEquiv (transport (fun X:Type => X) p).
refine (BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^)
                     (transport_Vp id p)
                     (transport_pV id p)
  _).
destruct p. reflexivity.
Defined.

Definition equiv_path (A B : Type) (p : A = B) : A ≃ B
  := BuildEquiv _ _ (transport (fun X:Type => X) p) _.

Axiom isequiv_equiv_path : forall (A B : Type), IsEquiv (equiv_path A B).

Existing Instance isequiv_equiv_path.

Definition path_universe_uncurried {A B : Type} (f : A ≃ B) : A = B
  := Equiv_inverse (BuildEquiv _ _ (equiv_path A B) _) f.

Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B)
  := path_universe_uncurried (BuildEquiv _ _ f feq).

Definition transport_path_universe_uncurried
           {A B : Type} (f : A ≃ B) (z : A)
  : transport (fun X:Type => X) (path_universe_uncurried f) z = f z.
Proof.
  pose (ap e_fun (e_retr (equiv_path A B) f)).
  exact (apD10 i z).
Defined.

Definition transport_path_universe
           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A)
  : transport (fun X:Type => X) (path_universe f) z = f z
  := transport_path_universe_uncurried (BuildEquiv A B f feq) z.

Definition path_universe_V_uncurried {funext :Funext} {A B : Type} (f : A ≃ B)
  : path_universe_uncurried (Equiv_inverse f) = (path_universe_uncurried f)^.
Proof.
  revert f.
  (* equiv_intro ((equiv_path_universe A B)^-1) p. simpl. *)
  (* transitivity (p^). *)
  (*   2: exact (inverse2 (eisretr (equiv_path_universe A B) p)^). *)
  (* transitivity (path_universe_uncurried (equiv_path B A p^)). *)
  (*   by refine (ap _ (equiv_path_V A B p)^). *)
  (* by refine (eissect (equiv_path B A) p^). *)
Admitted.

Definition path_universe_V {funext:Funext} {A B} `(f : A -> B) `{IsEquiv A B f}
  : path_universe (Equiv_inverse (BuildEquiv _ _ f _)) = (path_universe f)^
  := path_universe_V_uncurried (funext:=funext) (BuildEquiv A B f _).


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

From Equations Require Import Init.

Set Warnings "-notation-overridden".
Require Import Equations.HoTT.Logic.

Local Open Scope equations_scope.
Import Sigma_Notations.

(** Relations in Type *)
Set Universe Polymorphism.

(** ** Transitive closure *)

Section Transitive_Closure.
  Context {A : Type} (R : Relation A).

  (** Definition by direct transitive closure *)

  Inductive trans_clos (x: A) : A -> Type :=
    | t_step (y:A) : R x y -> trans_clos x y
    | t_trans (y z:A) : trans_clos x y -> trans_clos y z -> trans_clos x z.

  (** Alternative definition by transitive extension on the left *)

  Inductive trans_clos_1n (x: A) : A -> Type :=
    | t1n_step (y:A) : R x y -> trans_clos_1n x y
    | t1n_trans (y z:A) : R x y -> trans_clos_1n y z -> trans_clos_1n x z.

  (** Alternative definition by transitive extension on the right *)

  Inductive trans_clos_n1 (x: A) : A -> Type :=
    | tn1_step (y:A) : R x y -> trans_clos_n1 x y
    | tn1_trans (y z:A) : R y z -> trans_clos_n1 x y -> trans_clos_n1 x z.

End Transitive_Closure.

(** ** Reflexive closure *)

Section Reflexive_Closure.
  Context {A : Type} (R : Relation A).

  (** Definition by direct transitive closure *)

  Inductive clos_refl (x: A) : A -> Type :=
    | r_step (y:A) : R x y -> clos_refl x y
    | r_refl : clos_refl x x.

End Reflexive_Closure.

(** ** Reflexive-transitive closure *)

Section Reflexive_Transitive_Closure.
  Context {A : Type} (R : Relation A).

  (** Definition by direct reflexive-transitive closure *)

  Inductive clos_refl_trans (x:A) : A -> Type :=
    | rt_step (y:A) : R x y -> clos_refl_trans x y
    | rt_refl : clos_refl_trans x x
    | rt_trans (y z:A) :
          clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z.

  (** Alternative definition by transitive extension on the left *)

  Inductive clos_refl_trans_1n (x: A) : A -> Type :=
    | rt1n_refl : clos_refl_trans_1n x x
    | rt1n_trans (y z:A) :
         R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z.

  (** Alternative definition by transitive extension on the right *)

 Inductive clos_refl_trans_n1 (x: A) : A -> Type :=
    | rtn1_refl : clos_refl_trans_n1 x x
    | rtn1_trans (y z:A) :
        R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z.

End Reflexive_Transitive_Closure.

(** ** Reflexive-symmetric-transitive closure *)

Section Reflexive_Symmetric_Transitive_Closure.
  Context {A : Type} (R : Relation A).

  (** Definition by direct reflexive-symmetric-transitive closure *)

  Inductive clos_refl_sym_trans : Relation A :=
    | rst_step (x y:A) : R x y -> clos_refl_sym_trans x y
    | rst_refl (x:A) : clos_refl_sym_trans x x
    | rst_sym (x y:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y x
    | rst_trans (x y z:A) :
        clos_refl_sym_trans x y ->
        clos_refl_sym_trans y z -> clos_refl_sym_trans x z.

  (** Alternative definition by symmetric-transitive extension on the left *)

  Inductive clos_refl_sym_trans_1n (x: A) : A -> Type :=
    | rst1n_refl : clos_refl_sym_trans_1n x x
    | rst1n_trans (y z:A) : R x y + R y x ->
         clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z.

  (** Alternative definition by symmetric-transitive extension on the right *)

  Inductive clos_refl_sym_trans_n1 (x: A) : A -> Type :=
    | rstn1_refl : clos_refl_sym_trans_n1 x x
    | rstn1_trans (y z:A) : R y z + R z y ->
         clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z.

End Reflexive_Symmetric_Transitive_Closure.

(** ** Converse of a Relation *)

Section Converse.
  Context {A : Type} (R : Relation A).

  Definition transp (x y:A) := R y x.
End Converse.

(** ** Union of Relations *)

Section Union.
  Context {A : Type} (R1 R2 : Relation A).

  Definition union (x y:A) := (R1 x y + R2 x y)%type.
End Union.

(** ** Disjoint union of Relations *)

Section Disjoint_Union.
  Context {A B : Type}.
  Variable leA : A -> A -> Type.
  Variable leB : B -> B -> Type.

  Inductive le_AsB : A + B -> A + B -> Type :=
  | le_aa (x y:A) : leA x y -> le_AsB (inl x) (inl y)
  | le_ab (x:A) (y:B) : le_AsB (inl x) (inr y)
  | le_bb (x y:B) : leB x y -> le_AsB (inr x) (inr y).

End Disjoint_Union.

(** ** Lexicographic order on dependent pairs *)

Section Lexicographic_Product.
  Context {A : Type} {B : A -> Type}.
  Variable leA : A -> A -> Type.
  Variable leB : forall x:A, B x -> B x -> Type.

  Inductive lexprod : sigma B -> sigma B -> Type :=
    | left_lex :
      forall (x x':A) (y:B x) (y':B x'),
        leA x x' -> lexprod (x, y) (x', y')
    | right_lex :
      forall (x:A) (y y':B x),
        leB x y y' -> lexprod (x, y) (x, y').

End Lexicographic_Product.

(** ** Product of Relations *)

Section Symmetric_Product.
  Variable A : Type.
  Variable B : Type.
  Variable leA : A -> A -> Type.
  Variable leB : B -> B -> Type.

  Inductive symprod : A * B -> A * B -> Type :=
    | left_sym :
      forall x x':A, leA x x' -> forall y:B, symprod (pair x y) (pair x' y)
    | right_sym :
      forall y y':B, leB y y' -> forall x:A, symprod (pair x y) (pair x y').

End Symmetric_Product.

(** ** Multiset of two Relations *)

Section Swap.
  Variable A : Type.
  Variable R : A -> A -> Type.

  Inductive swapprod : A * A -> A * A -> Type :=
    | sp_noswap x y (p:A * A) : symprod A A R R (pair x y) p -> swapprod (pair x y) p
    | sp_swap x y (p:A * A) : symprod A A R R (pair x y) p -> swapprod (pair y x) p.
End Swap.

Local Open Scope list_scope.

Section Lexicographic_Exponentiation.

  Variable A : Set.
  Variable leA : A -> A -> Type.
  Let Nil := nil (A:=A).
  Let List := list A.

  Inductive Ltl : List -> List -> Type :=
    | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x)
    | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y)
    | Lt_tl (a:A) (x y:List) : Ltl x y -> Ltl (a :: x) (a :: y).

  Inductive Desc : List -> Type :=
    | d_nil : Desc Nil
    | d_one (x:A) : Desc (x :: Nil)
    | d_conc (x y:A) (l:List) :
        clos_refl leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).

  Definition Pow : Type := sigma Desc.

  Definition lex_exp (a b:Pow) : Type := Ltl a.1 b.1.

End Lexicographic_Exponentiation.

#[export] Hint Unfold transp union: Relations.
#[export] Hint Resolve t_step rt_step rt_refl rst_step rst_refl: Relations.
#[export] Hint Immediate rst_sym: Relations.


From Undecidability.L Require Import Util.L_facts Seval.
Require Import RelationClasses.

(* * Resource Measures *)
(* ** Big-Step Time Measure*)

Inductive timeBS : nat -> term -> term -> Prop :=
  timeBSVal s : timeBS 0 (lam s) (lam s)
| timeBSBeta (s s' t t' u : term) i j k l: timeBS i s (lam s') -> timeBS j t (lam t') -> timeBS k (subst s' 0 (lam t')) u -> l = (i+j+1+k) -> timeBS l (app s t) u.

Module Leftmost.

  (* ** Leftmost reduction *)

  Reserved Notation "s '≻lm' t" (at level 50).

  Inductive step_lm : term -> term -> Prop :=
  | step_lmApp  s t     : app (lam s) (lam t) ≻lm subst s 0 (lam t)
  | step_lmAppR s t  t' : t ≻lm t' -> app (lam s) t ≻lm app (lam s) t'
  | step_lmAppL s s' t  : s ≻lm s' -> app s t ≻lm app s' t
  where "s '≻lm' t" := (step_lm s t).
  #[local] Hint Constructors step_lm : core.

  Lemma step_lm_functional :
    functional step_lm.
  Proof.
    intros s t t' H1 H2.
    induction H1 in t',H2|-*;inv H2;try easy;try congruence. all:f_equal. all:apply IHstep_lm;eauto.
  Qed.

  Ltac inv_step_lm :=
    match goal with
    | H : step_lm (lam _) _ |- _ => inv H
    | H : step_lm (var _) _ |- _ => inv H
    | H : star step_lm (lam _) _ |- _ => inv H
    | H : star step_lm (var _) _ |- _ => inv H
    end.

  (* *** Small-Step_Lm Time Measure *)

#[global]
  Instance pow_step_lm_congL k:
    Proper ((pow step_lm k) ==> eq ==> (pow step_lm k)) app.
  Proof.
    intros s t R u ? <-. revert s t R u.
    induction k;cbn in *;intros ? ? R ?. congruence. destruct R as [s' [R1 R2]].
    exists (app s' u). firstorder.
  Qed.

#[global]
  Instance pow_step_lm_congR k:
    Proper (eq ==>(pow step_lm k) ==> (pow step_lm k)) (fun s t => app (lam s) t).
  Proof.
    intros s ? <- t u R. revert s t u R.
    induction k;cbn in *;intros ? ? ? R. congruence. destruct R as [t' [R1 R2]].
    exists (app (lam s) t'). firstorder.
  Qed.

#[global]
  Instance step_lm_step: subrelation step_lm step.
  Proof.
    induction 1;eauto using step.
  Qed.

  (* *** Small-Step_Lm Space Measure *)

  Definition redWithMaxSizeL := redWithMaxSize size step_lm.

  Lemma redWithMaxSizeL_congL m m' s s' t:
    redWithMaxSizeL m s s' -> m' = (1 + m + size t) -> redWithMaxSizeL m' (app s t) (app s' t).
  Proof.
    intros R Heq.
    induction R as [s | s s'] in m',t,Heq |-* .
    -apply redWithMaxSizeR. cbn. lia.
    -eapply redWithMaxSizeC. now eauto using step_lm. apply IHR. reflexivity.
     subst m m'. cbn. repeat eapply Nat.max_case_strong;lia.
  Qed.

  Lemma redWithMaxSizeL_congR m m' s t t':
    redWithMaxSizeL m t t' -> m' = (1 + m + size (lam s)) -> redWithMaxSizeL m' (app (lam s) t) (app (lam s) t').
  Proof.
    intros R Heq.
    induction R as [t | t t'] in m',s,Heq |-* .
    -apply redWithMaxSizeR. cbn in *. lia.
    -eapply redWithMaxSizeC. now eauto using step_lm. apply IHR. reflexivity.
     subst m m'. cbn -[plus]. repeat eapply Nat.max_case_strong;lia.
  Qed.

  Lemma step_lm_evaluatesIn s s' t k: s ≻lm s' -> timeBS k s' t -> timeBS (S k) s t.
  Proof.
    intros H; induction H in t,k|-*; intros;  try inv H0; eauto 20 using timeBS.
    eapply IHstep_lm in H4. econstructor; eauto. lia.
  Qed.

  Lemma timeBS_correct_lm s t k:
    (timeBS k s t <-> pow step_lm k s t /\ lambda t).
  Proof.
    split.
    -intros R.
     induction R.
     +unfold pow;cbn. eauto.
     +destruct IHR1 as [R1'].
      destruct IHR2 as [R2'].
      destruct IHR3 as [R3'].
      split;[|assumption].
      subst l.
      replace (i+j+1+k) with (i+(j+(1+k))) by lia.
      eapply pow_add.
      eexists;split.
      eapply pow_step_lm_congL;now eauto.
      eapply pow_add.
      eexists;split.
      eapply pow_step_lm_congR;now eauto.
      eapply pow_add.
      eexists;split.
      eapply (rcomp_1 step_lm). eauto.
      eauto.
    -intros [R lt].
     induction k in s,t,R,lt,R|-*.
     +inv R. inv lt. constructor.
     +change (S k) with (1+k) in R. eapply pow_add in R as (?&R'&?).
      eapply (rcomp_1 step_lm) in R'. eapply step_lm_evaluatesIn;eauto 10.
  Qed.

  (* *** Big-Step_Lm Space Measure*)

  Inductive spaceBS : nat -> term -> term -> Prop :=
    spaceBSVal s : spaceBS (size (lam s)) (lam s) (lam s)
  | spaceBSBeta (s s' t t' u : term) m1 m2 m3 m:
      spaceBS m1 s (lam s') ->
      spaceBS m2 t (lam t') ->
      spaceBS m3 (subst s' 0 (lam t')) u ->
      m = max (m1 + 1 + size t)
              (max (size (lam s') + 1 + m2) m3) ->
      spaceBS m (app s t) u.

  Lemma spaceBS_ge s t m: spaceBS m s t -> size s<= m /\ size t <= m.
  Proof.
    induction 1. lia.
    subst m. cbn -[plus]. all:(repeat apply Nat.max_case_strong;try lia).
  Qed.

  Lemma step_lm_evaluatesSpace s s' t m: s ≻lm s' -> spaceBS m s' t -> spaceBS (max (size s) m) s t.
  Proof.
    intros H; induction H in t,m|-*; intros H'.
    -inv H'.
     +destruct s;inv H1. destruct (Nat.eqb_spec n 0);inv H0.
      all:repeat econstructor.
      all:cbn -[plus].
      all:(repeat apply Nat.max_case_strong;try lia).
     +destruct s;inv H. now destruct (Nat.eqb_spec n 0);inv H0.
      econstructor. 1,2:econstructor. cbn.
      econstructor.
      1-4:now eauto.
      cbn -[plus].
      (repeat apply Nat.max_case_strong;intros;try lia).
    -inv H'. inv H2.
     specialize (spaceBS_ge H3) as [? ?].
     specialize (spaceBS_ge H3) as [? ?].
     apply IHstep_lm in H3.
     specialize (spaceBS_ge H5) as [? ?].
     specialize (spaceBS_ge H3) as [_ H''].
     econstructor;[now eauto using spaceBS..|].
     revert H''. cbn -[plus] in *.
     (repeat apply Nat.max_case_strong;intros;try lia).
    -inv H'.
     specialize (spaceBS_ge H2) as [? ?].
     eapply IHstep_lm in H2.
     specialize (spaceBS_ge H2) as [_ H7].
     specialize (spaceBS_ge H3) as [? ?].

     econstructor.
     1-3:eassumption.
     revert H7.
     cbn -[plus] in *.
     (repeat apply Nat.max_case_strong;intros;try lia).
  Qed.

  Lemma spaceBS_correct_lm s t m:
    spaceBS m s t <->
    redWithMaxSizeL m s t /\ lambda t.
  Proof.
    split.
    -intros R. induction R.
     +repeat econstructor.
     +destruct IHR1 as (R1'&?).
      destruct IHR2 as (R2'&?).
      destruct IHR3 as (R3'&?).
      split;[|firstorder].
      subst m.
      eapply redWithMaxSize_trans with (t:=app (lam s') t).
      { eapply redWithMaxSizeL_congL. eassumption. reflexivity. }

      eapply redWithMaxSize_trans with (t:=app (lam s') (lam t')).
      { eapply redWithMaxSizeL_congR. eassumption. reflexivity. }
      econstructor. constructor. eassumption. reflexivity. reflexivity.
      specialize (spaceBS_ge R2) as [_ H3];cbn in H3.
      cbn - [plus]. repeat eapply Nat.max_case_strong;lia.
    -intros (R&H).
     induction R as [t | s s' t m].
     +inv H;rename x into t. eauto using spaceBS.
     +inv H;rename m' into m. eapply step_lm_evaluatesSpace. eassumption. eauto.
  Qed.

  Lemma spaceBS_eval s t m:
    spaceBS m s t -> eval s t.
  Proof.
    intros (R&L) % spaceBS_correct_lm.
    split. 2:tauto.
    eapply redWithMaxSize_star in R.
    induction R. reflexivity. econstructor;eauto using step_lm_step.
  Qed.

End Leftmost.

Definition hasTime k s := exists t, evalIn k s t.
Definition hasSpace m s := maxP (fun m => exists s', s >* s' /\ m = size s' ) m.

Lemma hasSpace_iff m s :
  hasSpace m s <-> (forall s', s >* s' -> size s' <= m) /\ (exists s', s >* s' /\ size s' = m).
Proof.
  unfold hasSpace,maxP. firstorder. subst. firstorder.
Qed.

Lemma step_timeBS k s s' t: step s s' -> timeBS k s' t -> timeBS (S k) s t.
Proof.
  intros R E. induction R in k,E,t|-*.
  -eauto using timeBS.
  -inv E. eapply IHR in H2. econstructor. all:eauto;lia.
  -inv E. eapply IHR in H1. econstructor. all:eauto;lia.
Qed.

Lemma timeBS_evalIn s t k :
  timeBS k s t <-> evalIn k s t.
Proof.
  split.
  -induction 1 as [|? ? ? ? ? ? ? ? ? ? [IH1 ?] ? [IH2 ?] ? [IH3 ?]].
   +split. reflexivity. eauto.
   +unfold evalIn in *. split. 2:now eauto.
    subst l. rewrite <- !Nat.add_assoc.
    eapply pow_trans. now eapply pow_step_congL;eauto.
    eapply pow_trans. now eapply pow_step_congR;eauto.
    eapply pow_trans. eapply (rcomp_1 step). eauto.
    eauto.
  -unfold evalIn.
   induction k in s |- *.
   +unfold pow;cbn. intros [-> H]. inv H. constructor.
   +intros [(?&?&?) L]. eapply step_timeBS. all:eauto.
Qed.

Lemma timeBS_rect (P : nat -> term -> term -> Type)
  (H0 : forall s : term, P 0 (lam s) (lam s))
  (HR : forall (s s' t t' u : term) (i j k l : nat),
      timeBS i s (lam s') ->
        P i s (lam s') ->
        timeBS j t (lam t') ->
        P j t (lam t') ->
        timeBS k (subst s' 0 (lam t')) u ->
        P k (subst s' 0 (lam t')) u -> l = i + j + 1 + k -> P l (app s t) u):
  forall k s t, timeBS k s t -> P k s t.
Proof.
  intros n.
  intros s t H'%timeBS_evalIn.
  assert (H'':eval s t) by (eapply evalIn_eval_subrelation;eauto).
  revert n H'.
  induction H'' using eval_rect.
  { intros []. easy. now intros H'%timeBS_evalIn;exfalso. }
  intros n H'.
  eapply informative_evalIn in H''1 as (?&H1).
  eapply informative_evalIn in H''2 as (?&H2).
  eapply informative_evalIn in H''3 as (?&H3).
  destruct t'. 1,2:(now exfalso;destruct H2 as [? []]).
  eapply HR. 1-6:try (eapply timeBS_evalIn); eauto.
  eapply timeBS_evalIn in H'. inv H'.
  apply timeBS_evalIn in H5. apply timeBS_evalIn in H6. apply timeBS_evalIn in H8.
  do 3 lazymatch goal with
  | H : ?s ⇓(_) _ , H' : ?s ⇓(_) _ |- _ =>
  eapply evalIn_unique in H;[|exact H'];try destruct H as [-> [= ->]]
   end.
   nia.
Qed.

Lemma hasSpaceVal s : hasSpace (size (lam s)) (lam s).
Proof.
  econstructor.
  -repeat econstructor.
  -intros ? (?&R&?). inv R. all:easy.
Qed.

(* TODO: decompose this into lemmata? *)

Lemma hasSpaceBeta s s' m1 t t' m2 m3:
  hasSpace m1 s -> hasSpace m2 t ->
  s >* lam s' -> eval t t' ->
  hasSpace m3 (subst s' 0 t') ->
  hasSpace (max m3 (m1+m2+1)) (app s t).
Proof.
  intros H1 H2 R1 R2 [(u0&R'3&LB3) UB3].
  split.
  -destruct H1 as [(s0&R'1&LB1) _]. destruct H2 as  [(t0&R'2&LB2) _].
   apply Nat.max_case_strong;intros ?.
   +exists u0. rewrite R1. rewrite R2. rewrite step_Lproc. 2:now apply R2. easy.
   +exists (app s0 t0). split.
    *eapply star_step_app_proper. all:easy.
    *cbn. lia.
  -destruct H1 as [_ LB1]. destruct H2 as [_ LB2].
   intros m' (u1 & Ru & lequ1). remember (app s t) as st eqn:eqst.
   eapply Nat.max_le_iff.
   induction Ru as [? |? ? Ru Ru'] in s,t,lequ1, eqst, LB1, LB2,R1,R2 |-*;subst x.
   +right. rewrite lequ1.
    erewrite <- LB1, <- LB2. 2,3:eexists;split;[reflexivity|reflexivity].
    cbn;lia.
   +inv Ru'.
    *left. apply UB3.
     replace s' with s0 in *.
     2:{ inv R1. all:easy. }
     replace t' with (lam t0) in *.
     2:{ destruct R2 as [R2 H]. inv H. inv R2. all:easy. }
     eauto.
    *assert (R2'':eval t'0 t').
     {destruct R2 as [R2 H']. inv H'.
      split. 2:easy.
      eapply equiv_lambda. easy.
      rewrite <- H2, R2. reflexivity. }
     eapply IHRu.
     5,6:reflexivity.
     1,3-4:eassumption.
     intros ? (?&?&?). apply LB2. eexists. rewrite H2. eauto.
    *assert (R1'':s'0 >* (lam s')).
     {eapply equiv_lambda. easy.
      rewrite <- H2, R1. reflexivity. }
     eapply IHRu.
     5-6:reflexivity.
     2-4:eassumption.
     intros ? (?&?&?). apply LB1. eexists. rewrite H2. eauto.
Qed.

Lemma spaceBS_hasSpace m s t:
  Leftmost.spaceBS m s t -> exists m', hasSpace m' s /\ m <= m'.
Proof.
  induction 1 as [| s s' t t' u m1 m2 m3 m BS1 (m1'&IS1&leq1) BS2 (m2'&IS2&leq2) BS3 (m3'&IS3&leq3) ->].
  -do 2 eexists. apply hasSpaceVal. reflexivity.
  -eexists. split.
   eapply hasSpaceBeta. 1-2,5:eassumption.
   1,2:eapply Leftmost.spaceBS_eval;eauto.
   {
     eapply Leftmost.spaceBS_ge in BS1 as [].
     eapply Leftmost.spaceBS_ge in BS2 as [].
     eapply Leftmost.spaceBS_ge in BS3 as [].
     repeat eapply Nat.max_case_strong;lia.
   }
Qed.

Lemma hasSpace_step m s s':
  hasSpace m s -> s ≻ s' -> exists m', hasSpace m' s' /\ m' <= m.
Proof.
  (* this needs bounded search for come up with m' *)
Abort.


Require Import VST.floyd.proofauto.
Require Import VST.progs.fib.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Fixpoint fib_of_nat (n: nat): Z :=
  match n with
  | O => 0
  | S n' =>
    match n' with
    | O => 1
    | S n'' => fib_of_nat n'' + fib_of_nat n'
    end
  end.

Definition fib_of_Z (n: Z): Z := fib_of_nat (Z.to_nat n).

Theorem fib_0: fib_of_Z 0 = 0.
Proof. reflexivity. Qed.

Theorem fib_1: fib_of_Z 1 = 1.
Proof. reflexivity. Qed.

Theorem fib_rec: forall n, n >= 0 -> fib_of_Z (n + 2) = fib_of_Z n + fib_of_Z (n + 1).
Proof.
  intros.
  unfold fib_of_Z.
  rewrite !Z2Nat.inj_add, !(Nat.add_comm (Z.to_nat n)) by lia.
  reflexivity.
Qed.

Lemma fib_nonneg: forall n, 0 <= fib_of_Z n.
Proof.
  intros.
  unfold fib_of_Z.
  forget (Z.to_nat n) as m; clear.
  assert (0 <= fib_of_nat m /\ 0 <= fib_of_nat (S m)); [| tauto].
  induction m; [simpl; try lia |].

  destruct IHm.
  split; [auto |].
  change (fib_of_nat (S (S m))) with (fib_of_nat m + fib_of_nat (S m)).
  lia.
Qed.

Lemma fib_ordered: forall n, 0 <= n -> fib_of_Z n <= fib_of_Z (n + 1).
Proof.
  intros.
  destruct (zeq n 0); [subst; simpl; rewrite fib_0, fib_1; lia |].
  replace (n + 1) with (n - 1 + 2) by lia.
  rewrite fib_rec by lia.
  replace (n - 1 + 1) with n by lia.
  pose proof fib_nonneg (n -1).
  lia.
Qed.

Lemma fib_bound: forall n, 0 <= n < 46 -> 0 <= fib_of_Z n < Int.max_signed.
Proof.
  assert (fib_of_Z 0 = 0 -> fib_of_Z (0 + 1) = 1 -> forall n, 0 <= n < 46 -> 0 <= fib_of_Z n < Int.max_signed);
    [| intros; apply H; auto].
  do 46
  match goal with
  | |- fib_of_Z ?z = ?f0  -> fib_of_Z (?z + 1) = ?f1 -> forall n, ?z <= n < 46 -> _ =>
         let f2 := eval compute in (f0 + f1) in
         assert (fib_of_Z (z + 1) = f1 -> fib_of_Z (z + 2) = f2 -> forall n, z + 1 <= n < 46 ->0 <= fib_of_Z n < Int.max_signed); [
           replace (z + 2) with (z + 1 + 1) by lia |
           intros HH0 HH1; specialize (H HH1 ltac:(rewrite fib_rec by (simpl; lia); rewrite HH0, HH1; reflexivity));
           intros; destruct (zeq z n); [subst n; rewrite HH0; rep_lia | apply H; lia] (*;
           split; [apply fib_nonneg | specialize (H (n + 1) ltac:(lia)); pose proof fib_ordered n; lia]*)
           ]
  end.
  intros; simpl in *. lia.
Qed.

Definition fib_spec fun_id :=
 DECLARE fun_id
  WITH n : Z
  PRE  [ tint ]
     PROP (0 <= n < 45) (* 50th term is too large to be a 32bit int *)
     PARAMS (Vint (Int.repr n))
     SEP ()
  POST [ tint ]
     PROP () RETURN (Vint (Int.repr (fib_of_Z n)))
     SEP ().

Definition Gprog : funspecs :=
         ltac:(with_library prog [ fib_spec _fib_loop; fib_spec _fib_loop_save_var; fib_spec _fib_rec ]).

Lemma body_fib_loop: semax_body Vprog Gprog f_fib_loop (fib_spec _fib_loop).
Proof.
  start_function.
  forward.  (* a0 = 0; *)
  forward.  (* a1 = 1; *)
  forward_for_simple_bound n
    (EX i: Z,
    (PROP ()
     LOCAL (temp _a1 (Vint (Int.repr (fib_of_Z (i + 1)))); temp _a0 (Vint (Int.repr (fib_of_Z i))); temp _n (Vint (Int.repr n)))
     SEP ()))%assert.
  { (* Prove that loop invariant implies typechecking of loop condition *)
    entailer!!.
  }
  { (* Prove that loop body preserves invariant *)
    assert (0 <= fib_of_Z i < Int.max_signed /\
            0 <= fib_of_Z (i + 1) < Int.max_signed /\
            0 <= fib_of_Z i + fib_of_Z (i + 1) < Int.max_signed) as [R0 [R1 R2]].
    {
      rewrite <- fib_rec by lia.
      split; [| split]; apply fib_bound; lia.
    }
    forward. (* a2 = a0 + a1; *)
    forward. (* a0 = a1; *)
    forward. (* a1 = a2; *)
    entailer!!.
    rewrite <- fib_rec by lia.
    do 3 f_equal; lia.
  }
  forward. (* return a0; *)
Qed.

Lemma body_fib_rec: semax_body Vprog Gprog f_fib_rec (fib_spec _fib_rec).
Proof.
  start_function.
  forward_if.
  { forward. }
  forward_if.
  { forward. }
  forward_call (n - 2).
  forward_call (n - 1).
  assert (0 <= fib_of_Z (n - 2) < Int.max_signed /\
          0 <= fib_of_Z (n - 1) < Int.max_signed /\
          0 <= fib_of_Z (n - 2) + fib_of_Z (n - 1) < Int.max_signed) as [R0 [R1 R2]].
  {
    replace (n - 1) with (n - 2 + 1) at 3 4 by lia.
    rewrite <- fib_rec by lia.
    split; [| split]; apply fib_bound; lia.
  }
  forward.
  entailer!!.
  replace (n - 1) with (n - 2 + 1) by lia.
  rewrite <- fib_rec by lia.
  do 3 f_equal; lia.
Qed.

Lemma body_fib_loop_save_var: semax_body Vprog Gprog f_fib_loop_save_var (fib_spec _fib_loop_save_var).
Proof.
  start_function.
  forward.  (* a0 = 0; *)
  forward.  (* a1 = 1; *)
  forward_loop
    (EX i: Z,
    (PROP (0 <= i <= n)
     LOCAL (temp _a1 (Vint (Int.repr (fib_of_Z (i + 1))));
            temp _a0 (Vint (Int.repr (fib_of_Z i)));
            temp _n (Vint (Int.repr (n - i))))
     SEP ()))%assert
  break:
    (PROP ()
     LOCAL (temp _a0 (Vint (Int.repr (fib_of_Z n))))
     SEP ())%assert.
  { (* Prove that the precon implies the loop invariant *)
    Exists 0.
    entailer!.
  }
  { (* Prove that loop body preserves invariant *)
    Intros i.
    forward_if.
    2:{ (* Else branch *)
      forward. (* break; *)
      assert (i = n) by lia.
      entailer!!.
    }
    (* Then branch and other loop body *)
    assert (0 <= fib_of_Z i < Int.max_signed /\
            0 <= fib_of_Z (i + 1) < Int.max_signed /\
            0 <= fib_of_Z i + fib_of_Z (i + 1) < Int.max_signed) as [R0 [R1 R2]].
    {
      rewrite <- fib_rec by lia.
      split; [| split]; apply fib_bound; lia.
    }
    forward. (* a1 = a0 + a1; *)
    forward. (* a0 = a1 - a0; *)
    forward. (* -- n *)
    Exists (i + 1).
    entailer!!.
    split3.
    + rewrite <- fib_rec by lia.
      do 3 f_equal; lia.
    + do 2 f_equal; lia.
    + do 2 f_equal; lia.
  }
  forward. (* return a0; *)
Qed.


Require Import msl.Axioms. (*for extensionality*)
Require Import Arith.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_list.
Require Import sha.HMAC_spec_concat.
Require Import sha.ShaInstantiation.

Require Import Omega.

(*
Definition ltb (n m:nat):bool := if beq_nat n m then false else leb n m.
Lemma ltb_char n m: ltb n m = true <-> (n<m)%nat.
  unfold ltb. remember (beq_nat n m). destruct b; symmetry in Heqb; split; intros.
    inv H. apply beq_nat_true in Heqb. subst. omega.
   apply beq_nat_false in Heqb. apply leb_complete in H. omega.
   apply leb_correct. omega.
Qed.
*)

Function toBlocks (l : Blist) {measure length l} : list Blist :=
  (match l with
    | nil => nil
    | _ :: _ => if leb (List.length l) 511 then [firstn 512 l]
                else firstn 512 l :: toBlocks (skipn 512 l)
  end)%list.
Proof.
  intros. subst. remember ((b :: l0)%list) as l. clear Heql.
  apply leb_complete_conv in teq0.
  rewrite skipn_length; omega.
Qed.

Lemma toBlocks_injective: forall l1 l2 (BLKS: toBlocks l1 = toBlocks l2)
     (F1: InBlocks 512 l1)
     (F2: InBlocks 512 l2), l1 = l2.
Proof.
 intros l1.
  remember (toBlocks l1). generalize dependent l1.
  induction l. simpl; intros.
    rewrite toBlocks_equation in *.
    destruct l1.
      destruct l2; trivial.
      destruct (Compare_dec.leb (length (b :: l2)) 511); discriminate.
    destruct (Compare_dec.leb (length (b :: l1)) 511); discriminate.

  intros.
    rewrite toBlocks_equation in Heql, BLKS.
    destruct l1; try discriminate. destruct l2; try discriminate.
    inversion F1; clear F1. rewrite H0 in Heql.
    assert (L1: (511 < length (front ++ back))%nat).
      rewrite app_length, H. omega.
    rewrite leb_correct_conv in Heql; trivial.
    rewrite firstn_exact in Heql; trivial.
    rewrite skipn_exact in Heql; trivial.
    inversion Heql; clear Heql. subst a l.

    inversion F2; clear F2. rewrite H4 in BLKS.
    assert (L2: (511 < length (front0 ++ back0))%nat).
      rewrite app_length, H3. omega.
    rewrite leb_correct_conv in BLKS; trivial.
    rewrite firstn_exact in BLKS; trivial.
    rewrite skipn_exact in BLKS; trivial.
    inversion BLKS; clear BLKS. subst front0 full0 full.
    specialize (IHl _ H9 _ (eq_refl _) H5 H1). subst back0.
    rewrite <- H4 in H0. assumption.
Qed.

Definition sha_splitandpad_blocks (msg : Blist) : list Blist :=
  toBlocks (sha_splitandpad_inc msg).
(*
Definition sha_splitandpad_inc' (msg : Blist) : Blist :=
  concat (sha_splitandpad_blocks msg).
*)
Lemma InBlocks_Forall_512 b: (InBlocks 512 b) ->
      Forall (fun x : list bool => length x = 512%nat) (toBlocks b).
Proof. intros.
  remember (toBlocks b). generalize dependent b.
  induction l. simpl; intros. constructor.
  simpl; intros. rewrite toBlocks_equation in Heql. destruct b. discriminate.
  inversion H; clear H.
  rewrite H1, app_length, H0 in Heql.
  rewrite leb_correct_conv in Heql. 2: omega.
  rewrite firstn_exact in Heql; trivial.
  rewrite skipn_exact in Heql; trivial. inversion Heql; clear Heql.
  constructor. trivial.
  subst l. apply (IHl _ H2 (eq_refl _)).
Qed.

Lemma sha_splitandpad_blocks_512 m:
      Forall (fun x => length x = 512%nat) (sha_splitandpad_blocks m).
Proof. apply InBlocks_Forall_512. apply sha_splitandpad_inc_InBlocks.
Qed.

Lemma concat_toBlocks_id l: InBlocks 512 l -> concat (toBlocks l) = l.
Proof.
  intros len.
  unfold concat.
  induction len.

  * rewrite -> toBlocks_equation. reflexivity.
  *
    rewrite -> toBlocks_equation.
    destruct full.
      assert (@length bool nil = length (front ++ back)). rewrite <- H0; reflexivity.
      rewrite app_length, H in H1. remember (length back). clear - H1. rewrite plus_comm in H1. simpl in H1. omega.
    rewrite H0, app_length, H, leb_correct_conv. 2: omega.
    rewrite -> firstn_exact; trivial.
    rewrite -> skipn_exact; trivial.
    (*rewrite -> length_not_emp.*)
    simpl.
    rewrite -> IHlen.
    unfold id.
    reflexivity.
Qed.

Theorem HMAC_list_concat_sap_instantiated
        h (HH: forall x y, length x = c -> length y = b -> length (h x y)  = c)
        iv (IV: length iv = c) (op ip : Blist) (IL: length ip = b) (OL: length op = b)
        (FOLD_hash_blocks_eq : forall (l : Blist) (ls : list Blist),
               length l = b ->
               Forall (fun x : list bool => length x = b) ls ->
               fold_left h (l :: ls) iv =
               hash_blocks_bits _ B h iv (l ++ concat ls))
        : forall (k m : Blist), length k = b ->
  HMAC_List.HMAC c p h iv sha_splitandpad_blocks fpad op ip k m =
  (* Note use of sha_splitandpad_blocks and sha_splitandpad_inc' (= concat the blocks) *)
  HMAC_Concat.HMAC c p B h iv sha_splitandpad_inc fpad op ip k m.
Proof. intros.
  apply HMAC_List.HMAC_list_concat; trivial.
    apply fpad_length.
    apply sha_splitandpad_blocks_512.
    unfold sha_splitandpad_blocks; intros. rewrite concat_toBlocks_id; trivial.
      apply sha_splitandpad_inc_InBlocks.
Qed.

Lemma len_min : forall {A : Type} (l : list A), (length l >= 0)%nat.
Proof. intros. destruct l; simpl. omega. omega. Qed.

Theorem fold_hash_blocks_eq_ind : forall (l : list Blist) (iv : Blist),
                                    Forall (fun x => length x = 512%nat) l ->
                                    fold_left sha_h l iv =
                                    hash_blocks_bits _ B sha_h iv (concat l).
Proof.
  intros l.
  induction l as [ | l ls]; intros iv len_l.

  * simpl. reflexivity.
  *
    rewrite -> Forall_forall in len_l. simpl.
    rewrite hash_blocks_bits_equation.
    rewrite -> firstn_exact, -> skipn_exact, -> length_not_emp.
  - apply IHls.
    apply Forall_forall; intros.
    apply len_l.
    apply in_cons.
    apply H.
  - rewrite -> app_length.
    assert (length l = 512%nat). apply len_l. unfold In. auto.
    rewrite -> H.
    specialize (len_min ls).
    omega.
  - apply len_l. unfold In. auto.
  - apply len_l. unfold In. auto.
Qed.

Theorem fold_hash_blocks_eq : forall (l : Blist) (ls : list Blist),
                                length l = 512%nat ->
                                Forall (fun x => length x = 512%nat) ls ->
                                fold_left sha_h (l :: ls) sha_iv =
                                hash_blocks_bits _ B sha_h sha_iv (l ++ concat ls).
Proof.
  intros l ls len_l len_ls.
  pose proof fold_hash_blocks_eq_ind as fold_ind.
  simpl.
  rewrite hash_blocks_bits_equation.
  rewrite -> firstn_exact. rewrite -> skipn_exact.
  rewrite -> length_not_emp.
  apply fold_ind.
  * apply len_ls.
  * rewrite -> app_length.
    rewrite len_l.
    specialize (len_min ls).
    omega.
  * apply len_l.
  * apply len_l.
Qed.

Theorem HMAC_list_concat_explicit : forall (k m : Blist) (op ip : Blist),
                             length k = b ->
                             length op = b ->
                             length ip = b ->
  HMAC_List.HMAC c p sha_h sha_iv sha_splitandpad_blocks fpad op ip k m =
  (* Note use of sha_splitandpad_blocks and sha_splitandpad_inc' (= concat the blocks) *)
  HMAC_Concat.HMAC c p B sha_h sha_iv sha_splitandpad_inc fpad op ip k m.
Proof.
  intros k m op ip k_len op_len ip_len.
  apply HMAC_list_concat_sap_instantiated; trivial.
    apply sha_h_length.
    apply fold_hash_blocks_eq.
Qed.

(* since sha_splitandpad_inc is used instead of the modified version in the Concat-Pad proof
Lemma sha_splitandpad_inc_eq : sha_splitandpad_inc = sha_splitandpad_inc'.
Proof.
  extensionality msg.
  unfold sha_splitandpad_inc'. unfold sha_splitandpad_blocks.
  rewrite toBlocks_equation.
  remember (sha_splitandpad_inc msg).
  destruct b. reflexivity. unfold sha_splitandpad_inc in Heqb. rewrite Heqb. clear Heqb.
  destruct (sha_splitandpad_inc_length msg) as [k [K HK]].
  unfold sha_splitandpad_inc in HK. rewrite HK.
  rewrite leb_correct_conv. 2: omega.
  remember (pad_inc (bitsToBytes msg)). clear Heql.
  symmetry.
  assert (HH: (firstn 512 (bytesToBits l) :: toBlocks (skipn 512 (bytesToBits l))
               = toBlocks  (bytesToBits l))%list).
    remember (bytesToBits l) as bits. rewrite (toBlocks_equation bits).
    destruct bits. destruct l; simpl in *. omega. discriminate.
    (*rewrite Heqbits. clear Heqbits. *)
    rewrite leb_correct_conv. trivial. rewrite HK. omega.
  rewrite HH. apply concat_toBlocks_id.
  apply InBlocks_len. rewrite HK. exists k. omega.
Qed.*)

Lemma toBlocks_app_split l1 l2: length l1 = 512%nat ->
      toBlocks (l1 ++ l2) = toBlocks l1 ++ toBlocks l2.
Proof. intros.
  rewrite toBlocks_equation. rewrite app_length.
  rewrite firstn_exact; trivial.
  rewrite skipn_exact; trivial.
  remember (l1 ++ l2).
  destruct l.
  { assert (@length bool nil = length (l1 ++ l2)). rewrite <- Heql; trivial.
    rewrite app_length, H in H0. rewrite plus_comm in H0. simpl in H0. omega. }
  { rewrite  leb_correct_conv. 2: rewrite H, plus_comm; omega.
    remember (toBlocks l2).
    rewrite toBlocks_equation.
    destruct l1. simpl in H; omega.
    rewrite leb_correct_conv. 2: rewrite H; omega.
    rewrite sublist.firstn_same. 2: rewrite H; omega.
    rewrite skipn_short. 2: rewrite H; omega.
    rewrite toBlocks_equation. trivial. }
Qed.