(**

This file contains the final step in the formalization of multisorted binding signatures:

- Construction of a monad on Set/sort from a multisorted signature
  ([MultiSortedSigToMonad])

Written by: Anders Mörtberg, 2016. The formalization follows a note
written by Benedikt Ahrens and Ralph Matthes, and is also inspired by
discussions with them and Vladimir Voevodsky.

*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Slice.
Require Import UniMath.CategoryTheory.slicecat.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.
Require Import UniMath.SubstitutionSystems.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.MonadsMultiSorted.

Require Import UniMath.SubstitutionSystems.MultiSorted.

Local Open Scope cat.

Local Notation "C / X" := (slicecat_ob C X).
Local Notation "C / X" := (slice_precat_data C X).
Local Notation "C / X" := (slice_cat C X).

(** * Definition of multisorted binding signatures *)
Section MBindingSig.

Context (sort : hSet).

Local Definition HSET_over_sort : category.
Proof.
exists (HSET / sort).
now apply has_homsets_slice_precat.
Defined.

(** * Construction of a monad from a multisorted signature *)
Section monad.

Let Id_H := Id_H (HSET / sort) (BinCoproducts_HSET_slice sort).

(* ** Construction of initial algebra for a signature with strength on Set / sort *)
Definition SignatureInitialAlgebraSetSort
  (H : Signature HSET_over_sort HSET_over_sort HSET_over_sort) (Hs : is_omega_cocont H) :
  Initial (FunctorAlg (Id_H H)).
Proof.
use colimAlgInitial.
- apply Initial_functor_precat, Initial_slice_precat, InitialHSET.
- apply (is_omega_cocont_Id_H), Hs.
- apply ColimsFunctorCategory_of_shape, slice_precat_colims_of_shape,
        ColimsHSET_of_shape.
Defined.

Let HSS := @hss_category _ (BinCoproducts_HSET_slice sort).

(* ** Multisorted signature to a HSS *)
Definition MultiSortedSigToHSS (sig : MultiSortedSig sort) :
  HSS (MultiSortedSigToSignature sort sig).
Proof.
apply SignatureToHSS.
+ apply Initial_slice_precat, InitialHSET.
+ apply slice_precat_colims_of_shape, ColimsHSET_of_shape.
+ apply is_omega_cocont_MultiSortedSigToSignature.
  apply slice_precat_colims_of_shape, ColimsHSET_of_shape.
Defined.

(* The above HSS is initial *)
Definition MultiSortedSigToHSSisInitial (sig : MultiSortedSig sort) :
  isInitial _ (MultiSortedSigToHSS sig).
Proof.
now unfold MultiSortedSigToHSS, SignatureToHSS; destruct InitialHSS.
Qed.

(** ** Function from multisorted binding signatures to monads *)
Definition MultiSortedSigToMonad (sig : MultiSortedSig sort) : Monad (HSET / sort).
Proof.
use Monad_from_hss.
- apply BinCoproducts_HSET_slice.
- apply (MultiSortedSigToSignature sort sig).
- apply MultiSortedSigToHSS.
Defined.

End monad.

End MBindingSig.


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

Require Import bedrock.prelude.base.
Require Import bedrock.prelude.list_numbers.
From bedrock.lang.cpp.arith Require Import types builtins operator.

Import arith.builtins.churn_bits.

Section FromToBytes.
  Section ExtraFacts.
    Lemma repeat_cons_app:
      forall (A: Type) (a: A) (cnt: nat),
        (a :: repeat a cnt) = repeat a cnt ++ [a].
    Proof.
      induction cnt => //=.
      by rewrite IHcnt.
    Qed.

    Lemma rev_repeat:
      forall (A: Type) (a: A) (cnt: nat),
        rev (repeat a cnt) = repeat a cnt.
    Proof.
      induction cnt => //=.
      by rewrite IHcnt repeat_cons_app.
    Qed.

    Lemma Z_shiftr_small:
      forall v e,
        (0 <= e)%Z ->
        (0 <= v)%Z ->
        (v < 2 ^ e)%Z ->
        (v ≫ e = 0)%Z.
    Proof.
      intros; rewrite Z.shiftr_div_pow2; try lia.
      rewrite Z.div_small; lia.
    Qed.

    Lemma Z_pow2_trans_nat_l:
      forall v (a b: nat),
        (v < 2 ^ (8 * b))%Z ->
        (v < 2 ^ (8 * (a + b)%nat))%Z.
    Proof.
      intros; destruct a.
      - by replace (8 * (0%nat + b))%Z with (8 * b)%Z by lia.
      - eapply Z.lt_trans; eauto; apply Z.pow_lt_mono_r; lia.
    Qed.

    Lemma Z_pow2_trans_nat_r:
      forall v (a b: nat),
        (v < 2 ^ (8 * a))%Z ->
        (v < 2 ^ (8 * (a + b)%nat))%Z.
    Proof.
      intros; destruct b.
      - by rewrite -plus_n_O.
      - eapply Z.lt_trans; eauto; apply Z.pow_lt_mono_r; lia.
    Qed.

    Lemma Z_land_ldiff_no_overlap (mask offset v: Z) :
        (0 < mask)%Z ->
        (0 <= offset)%Z ->
        (0 <= v)%Z ->
        Z.land (mask ≪ offset) (Z.ldiff v (Z.ones offset)) = Z.land (mask ≪ offset) v.
    Proof.
    (* Intuition: the ldiff is going to remove the lowest
         (idx+cnt) bytes, but the `255 ≪ (8 * (idx+cnt))`
         mask doesn't overlap with any of those bits
         so it is effectively a no-op.
     *)
      intros **.
      apply Z.bits_inj' => n ?.
      rewrite !Z.land_spec Z.ldiff_spec Z.shiftl_spec // Z.testbit_ones_nonneg; try lia.
      destruct (n <? offset)%Z eqn:Hn => /=; rewrite ?andb_true_r //.
      move: Hn => /Z.ltb_lt?.
      rewrite !andb_false_r Z.testbit_neg_r //. lia.
    Qed.

    Lemma Z_land_ldiff_upper_byte (offset v: Z) :
        (0 <= offset)%Z ->
        (2^(8*offset) <= v)%Z ->
        (v < 2^(8*Z.succ offset))%Z ->
        Z.ldiff v (Z.ones (8 * offset)) = Z.land (255 ≪ (8 * offset)) v.
    Proof.
    (* Intuition: since `v < 2^(8*(idx+S cnt))`, we know
         that there aren't going to be any bits
         beyond the `255 ≪ (8 * (idx+cnt))` mask
         which will be introduced by the change to ldiff.
     *)
      intros.
      apply Z.bits_inj' => n ?.
      rewrite !Z.land_spec Z.ldiff_spec Z.shiftl_spec // Z.testbit_ones_nonneg; try lia.
      destruct (n <? 8*offset)%Z eqn:Hn => //=; rewrite ?andb_true_r ?andb_false_r //.
      - apply Z.ltb_lt in Hn; rewrite Z.testbit_neg_r ?andb_false_l //=; lia.
      - apply Z.ltb_ge in Hn.
        replace (8 * Z.succ offset)%Z with (8 + (8 * offset))%Z in H1 by lia.
        change (255)%Z with (Z.ones 8).
        destruct (8 + (8 * offset) <? n)%Z eqn:Hn' => //=.
        + rewrite Z.bits_above_log2 ?andb_false_r //.
          * apply Z.le_trans with (m := (2^(8*offset))%Z); try apply Z.pow_nonneg; lia.
          * apply Z.log2_lt_pow2.
            -- eapply Z.lt_le_trans; eauto; apply Z.pow_pos_nonneg; lia.
            -- eapply Z.lt_trans; eauto.
               apply Z.ltb_lt in Hn'.
               apply Z.pow_lt_mono_r; try lia.
        + apply Z.ltb_ge in Hn'.
          destruct (8 + (8 * offset) =? n)%Z eqn:Hn'' => //=.
          * apply Z.eqb_eq in Hn''; subst.
            rewrite Z.bits_above_log2 ?andb_false_l ?andb_false_r //.
            -- apply Z.le_trans with (m := (2^(8*offset))%Z);
                 eauto; apply Z.pow_nonneg; lia.
            -- apply Z.log2_lt_pow2; lia.
          * apply Z.eqb_neq in Hn''.
            assert (n < 8 + 8 * offset)%Z as Hn''' by lia.
            rewrite Z.ones_spec_low ?andb_true_l //; lia.
    Qed.

    Lemma Z_ldiff_split:
      forall (cnt idx: nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*(idx+S cnt)))%Z ->
        Z.ldiff v (Z.ones (8 * idx)) =
        Z.lor (Z.land (Z.ones (8 * cnt) ≪ (8 * idx)) v)
              (Z.land (Z.ones 8 ≪ (8 * (idx + cnt)%nat)) v).
    Proof.
      intros cnt idx v Hlower Hupper.
      assert (v = 0 \/ 0 < v)%Z as [Hlower' | Hlower'] by lia;
        [subst; by rewrite !Z.land_0_r Z.lor_diag Z.ldiff_0_l | clear Hlower].
      apply Z.bits_inj'=> n ?.
      rewrite Z.lor_spec Z.ldiff_spec !Z.land_spec !Z.shiftl_spec; try lia.
      rewrite !Z.testbit_ones; try lia.
      churn_bits'.
      apply Z.bits_above_log2; try lia.
      assert (8 * (idx+S cnt)%nat <= n)%Z by lia.
      eapply Z.lt_le_trans; eauto.
      apply Z.log2_lt_pow2; try lia.
    Qed.
  End ExtraFacts.

  Section ToBytes_internal.
    Definition _Z_to_bytes_unsigned_le' (idx: nat) (cnt: nat) (v: Z): list N :=
      map (Z.to_N ∘ _get_byte v) $ seq idx cnt.

    Definition _Z_to_bytes_unsigned_le (cnt: nat) (v: Z): list N :=
      _Z_to_bytes_unsigned_le' 0 cnt v.

    Definition _Z_to_bytes_le (cnt: nat) (sgn: signed) (v: Z): list N :=
      _Z_to_bytes_unsigned_le
        cnt (match sgn with
             | Signed   => to_unsigned_bits (8 * N.of_nat cnt) v
             | Unsigned => v
             end).

    (* NOTE: This will be sealed once we finish the proofs for this section. *)
    Definition _Z_to_bytes_def (cnt: nat) (endianness: endian) (sgn: signed) (v: Z): list N :=
      let little := _Z_to_bytes_le cnt sgn v in
      match endianness with
      | Little => little
      | Big => List.rev little
      end.
  End ToBytes_internal.

  Section ToBytesFacts_internal.
    #[local] Transparent _get_byte _set_byte.

    Lemma _Z_to_bytes_unsigned_le'_length:
      forall idx cnt v,
        length (_Z_to_bytes_unsigned_le' idx cnt v) = cnt.
    Proof.
      rewrite /_Z_to_bytes_unsigned_le' => idx cnt v //=;
        by rewrite map_length seq_length.
    Qed.

    Definition _Z_to_bytes_unsigned_le_length:
      forall cnt v,
        length (_Z_to_bytes_unsigned_le cnt v) = cnt.
    Proof.
      rewrite /_Z_to_bytes_unsigned_le => * //=;
        by apply _Z_to_bytes_unsigned_le'_length.
    Qed.

    Lemma _Z_to_bytes_le_length:
      forall cnt sgn v,
        length (_Z_to_bytes_le cnt sgn v) = cnt.
    Proof.
      rewrite /_Z_to_bytes_le => * //=;
        by apply _Z_to_bytes_unsigned_le_length.
    Qed.

    Lemma _Z_to_bytes_def_length:
      forall cnt endianness sgn v,
        length (_Z_to_bytes_def cnt endianness sgn v) = cnt.
    Proof.
      rewrite /_Z_to_bytes_def => cnt [ | ] sgn v //=;
        try rewrite rev_length;
        by apply _Z_to_bytes_le_length.
    Qed.

    Lemma _Z_to_bytes_unsigned_le'_0_bytes:
      forall (idx: nat) (v: Z),
        _Z_to_bytes_unsigned_le' idx 0 v = [].
    Proof. done. Qed.

    Lemma _Z_to_bytes_unsigned_le_0_bytes:
      forall (v: Z),
        _Z_to_bytes_unsigned_le 0 v = [].
    Proof. apply (_Z_to_bytes_unsigned_le'_0_bytes 0). Qed.

    Lemma _Z_to_bytes_le_0_bytes:
      forall sgn (v: Z),
        _Z_to_bytes_le 0 sgn v = [].
    Proof.
      move=> [ | ] v; rewrite /_Z_to_bytes_le;
        [rewrite N.mul_0_r trim_0_l | ];
        apply _Z_to_bytes_unsigned_le_0_bytes.
    Qed.

    Lemma _Z_to_bytes_def_0_bytes:
      forall endianness sgn (v: Z),
        _Z_to_bytes_def 0 endianness sgn v = [].
    Proof.
      move=> [ | ] sgn v;
        by rewrite /_Z_to_bytes_def _Z_to_bytes_le_0_bytes //=.
    Qed.

    Lemma _Z_to_bytes_unsigned_le'_0_value:
      forall (idx cnt: nat),
        _Z_to_bytes_unsigned_le' idx cnt 0 = repeat 0%N cnt.
    Proof.
      induction cnt => //=.
      rewrite /_Z_to_bytes_unsigned_le'.
      rewrite seq_S map_app repeat_cons_app //=.
      rewrite _get_byte_0; f_equal=> //=.
    Qed.

    Lemma _Z_to_bytes_unsigned_le_0_value:
      forall (cnt: nat),
        _Z_to_bytes_unsigned_le cnt 0 = repeat 0%N cnt.
    Proof. apply _Z_to_bytes_unsigned_le'_0_value. Qed.

    Lemma _Z_to_bytes_le_0_value:
      forall (cnt: nat) sgn,
        _Z_to_bytes_le cnt sgn 0 = repeat 0%N cnt.
    Proof.
      move=> cnt [ | ]; rewrite /_Z_to_bytes_le;
        [rewrite trim_0_r | ];
        apply _Z_to_bytes_unsigned_le_0_value.
    Qed.

    Lemma _Z_to_bytes_def_0_value:
      forall sgn endianness (cnt: nat),
        _Z_to_bytes_def cnt endianness sgn 0 = repeat 0%N cnt.
    Proof.
      move=> sgn [ | ] cnt;
        rewrite /_Z_to_bytes_def
                _Z_to_bytes_le_0_value //=;
        by rewrite rev_repeat.
    Qed.

    Lemma _Z_to_bytes_unsigned_le'_S_cnt:
      forall (idx cnt: nat) (v: Z),
        _Z_to_bytes_unsigned_le' idx (S cnt) v =
        _Z_to_bytes_unsigned_le' idx cnt v ++
        _Z_to_bytes_unsigned_le' (idx+cnt) 1 v.
    Proof.
      intros; generalize dependent idx;
        induction cnt; intros=> //=.
      - by rewrite Nat.add_0_r.
      - rewrite /_Z_to_bytes_unsigned_le'.
        rewrite seq_S map_app //=.
    Qed.

    Lemma _Z_to_bytes_unsigned_le_S_cnt:
      forall (cnt: nat) (v: Z),
        _Z_to_bytes_unsigned_le (S cnt) v =
        _Z_to_bytes_unsigned_le' 0 cnt v ++
        _Z_to_bytes_unsigned_le' cnt 1 v.
    Proof. apply _Z_to_bytes_unsigned_le'_S_cnt. Qed.

    Lemma _Z_to_bytes_unsigned_le'_small:
      forall (idx cnt: nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*idx))%Z ->
        _Z_to_bytes_unsigned_le' idx cnt v =
        repeat 0%N cnt.
    Proof.
      intros; generalize dependent idx;
        induction cnt ; intros=> //=.
      rewrite _Z_to_bytes_unsigned_le'_S_cnt
              /_Z_to_bytes_unsigned_le'
              repeat_cons_app //=; f_equal.
      - erewrite <- IHcnt; eauto.
      - rewrite /_get_byte Z_shiftr_small; try lia;
          [ rewrite Z.land_0_l
          | apply Z_pow2_trans_nat_r]=> //=.
    Qed.

    Lemma _Z_to_bytes_unsigned_le'_shrink_cnt:
      forall (idx cnt cnt': nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*cnt))%Z ->
        cnt < cnt' ->
        _Z_to_bytes_unsigned_le' idx cnt' v =
        _Z_to_bytes_unsigned_le' idx cnt v ++ repeat 0%N (cnt' - cnt).
    Proof.
      intros; generalize dependent idx; generalize dependent cnt;
        induction cnt'; intros=> //=; [lia | ].
      replace (S cnt' - cnt) with (S (cnt' - cnt)) by lia; simpl.
      assert (cnt = cnt' \/ cnt < cnt') as [Hcnt | Hcnt] by lia.
      - subst; rewrite _Z_to_bytes_unsigned_le'_S_cnt; f_equal.
        rewrite Nat.sub_diag /_Z_to_bytes_unsigned_le' //=.
        rewrite /_get_byte Z_shiftr_small; try lia;
          [ rewrite Z.land_0_l
          | apply Z_pow2_trans_nat_l]=> //=.
      - rewrite repeat_cons_app app_assoc.
        rewrite -IHcnt'; try lia.
        rewrite _Z_to_bytes_unsigned_le'_S_cnt //=; f_equal.
        rewrite /_Z_to_bytes_unsigned_le' //=.
        rewrite /_get_byte Z_shiftr_small; try lia;
          [ rewrite Z.land_0_l
          | eapply Z.lt_trans; eauto; apply Z.pow_lt_mono_r; lia]=> //=.
    Qed.

    Lemma _Z_to_bytes_unsigned_le_shrink_cnt:
      forall (cnt cnt': nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*cnt))%Z ->
        cnt < cnt' ->
        _Z_to_bytes_unsigned_le cnt' v =
        _Z_to_bytes_unsigned_le cnt v ++ repeat 0%N (cnt' - cnt).
    Proof. apply _Z_to_bytes_unsigned_le'_shrink_cnt. Qed.

    Lemma _Z_to_bytes_unsigned_le'_S_idx:
      forall (idx cnt: nat) (v: Z),
        (0 <= v)%Z ->
        _Z_to_bytes_unsigned_le' (S idx) cnt v =
        _Z_to_bytes_unsigned_le' idx cnt (v ≫ 8).
    Proof.
      intros idx cnt v Hlower; generalize dependent idx;
        induction cnt; intros=> //=.
      rewrite /_Z_to_bytes_unsigned_le' //=; f_equal.
      - rewrite /_get_byte Z.shiftr_shiftr; try lia.
        by replace (8 + 8 * idx)%Z with (8 * S idx)%Z by lia.
      - fold (_Z_to_bytes_unsigned_le' (S (S idx)) cnt v).
        fold (_Z_to_bytes_unsigned_le' (S idx) cnt (v ≫ 8)).
        assert (v < 2^(8*cnt) \/ 2^(8*cnt) <= v)%Z as [Hv | Hv] by lia.
        + by apply IHcnt.
        + rewrite /_Z_to_bytes_unsigned_le' //=.
          rewrite -seq_shift map_map.
          generalize (seq (S idx) cnt); induction l=> //=; f_equal.
          * rewrite /_get_byte Z.shiftr_shiftr; try lia.
            by replace (8 + 8 * a)%Z with (8 * S a)%Z by lia.
          * apply IHl.
    Qed.
  End ToBytesFacts_internal.

  Section FromBytes_internal.
    Definition _Z_from_bytes_unsigned_le' (idx: nat) (bytes: list N): Z :=
      foldr (fun '(idx, byte) acc => Z.lor (_set_byte (Z.of_N byte) idx) acc)
            0%Z (zip (seq idx (length bytes)) bytes).

    Definition _Z_from_bytes_unsigned_le (bytes: list N): Z :=
      _Z_from_bytes_unsigned_le' 0 bytes.

    Definition _Z_from_bytes_le (sgn: signed) (bytes: list N): Z :=
      let unsigned := _Z_from_bytes_unsigned_le bytes in
      match sgn with
      | Signed => to_signed_bits (8 * N.of_nat (length bytes)) unsigned
      | Unsigned => unsigned
      end.

    (* NOTE: This will be sealed once we finish the proofs for this section. *)
    Definition _Z_from_bytes_def (endianness: endian) (sgn: signed) (bytes: list N): Z :=
      _Z_from_bytes_le
        sgn match endianness with
            | Little => bytes
            | Big    => List.rev bytes
            end.
  End FromBytes_internal.

  Section FromBytesFacts_internal.
    Lemma _Z_from_bytes_unsigned_le'_nil:
      forall (idx: nat),
        _Z_from_bytes_unsigned_le' idx [] = 0%Z.
    Proof. rewrite /_Z_from_bytes_unsigned_le' //=. Qed.

    Lemma _Z_from_bytes_unsigned_le_nil:
      _Z_from_bytes_unsigned_le [] = 0%Z.
    Proof. apply _Z_from_bytes_unsigned_le'_nil. Qed.

    Lemma _Z_from_bytes_le_nil:
      forall sgn,
      _Z_from_bytes_le sgn [] = 0%Z.
    Proof.
      move=> [ | ];
        rewrite /_Z_from_bytes_le
                _Z_from_bytes_unsigned_le_nil //=.
    Qed.

    Lemma _Z_from_bytes_def_nil:
      forall endianness sgn,
        _Z_from_bytes_def endianness sgn [] = 0%Z.
    Proof.
      move=> [ | ] sgn;
        by rewrite /_Z_from_bytes_def /rev
                   _Z_from_bytes_le_nil.
    Qed.

    Lemma _Z_from_bytes_unsigned_le'_cons:
      forall (idx: nat) (byte: N) (bytes: list N),
        _Z_from_bytes_unsigned_le' idx (byte :: bytes) =
        Z.lor (_Z_from_bytes_unsigned_le' idx [byte])
              (_Z_from_bytes_unsigned_le' (S idx) bytes).
    Proof.
      intros; generalize dependent idx; generalize dependent byte;
        induction bytes => //=; intros.
      - rewrite _Z_from_bytes_unsigned_le'_nil Z.lor_0_r; lia.
      - rewrite /_Z_from_bytes_unsigned_le' //=.
        by rewrite Z.lor_0_r.
    Qed.

    Lemma _Z_from_bytes_unsigned_le_cons:
      forall (byte: N) (bytes: list N),
        _Z_from_bytes_unsigned_le (byte :: bytes) =
        Z.lor (_Z_from_bytes_unsigned_le' 0 [byte])
              (_Z_from_bytes_unsigned_le' 1 bytes).
    Proof. apply _Z_from_bytes_unsigned_le'_cons. Qed.

    Lemma _Z_from_bytes_unsigned_le'_app:
      forall (idx: nat) (bs1 bs2: list N),
        _Z_from_bytes_unsigned_le' idx (bs1 ++ bs2) =
        Z.lor (_Z_from_bytes_unsigned_le' idx bs1)
              (_Z_from_bytes_unsigned_le' (idx + length bs1) bs2).
    Proof.
      intros; generalize dependent idx; generalize dependent bs2;
        induction bs1 => //=; intros.
      - repeat rewrite _Z_from_bytes_unsigned_le'_nil.
        replace (idx + 0) with idx by lia.
        by rewrite Z.lor_0_l.
      - rewrite _Z_from_bytes_unsigned_le'_cons.
        rewrite (_Z_from_bytes_unsigned_le'_cons idx a bs1).
        rewrite IHbs1.
        rewrite Nat.add_succ_r.
        by rewrite Z.lor_assoc.
    Qed.

    Lemma _Z_from_bytes_unsigned_le_app:
      forall (bs1 bs2: list N),
        _Z_from_bytes_unsigned_le (bs1 ++ bs2) =
        Z.lor (_Z_from_bytes_unsigned_le' 0 bs1)
              (_Z_from_bytes_unsigned_le' (length bs1) bs2).
    Proof. apply _Z_from_bytes_unsigned_le'_app. Qed.

    Lemma _Z_from_bytes_unsigned_le'_0s:
      forall (idx cnt: nat),
        _Z_from_bytes_unsigned_le' idx (repeat 0%N cnt) = 0%Z.
    Proof.
      intros; generalize dependent idx.
      induction cnt => idx //=.
      rewrite _Z_from_bytes_unsigned_le'_cons.
      rewrite IHcnt.
      rewrite /_Z_from_bytes_unsigned_le' //=.
      by rewrite _set_byte_0 !Z.lor_0_r.
    Qed.

    Lemma _Z_from_bytes_unsigned_le_0s:
      forall (cnt: nat),
        _Z_from_bytes_unsigned_le (repeat 0%N cnt) = 0%Z.
    Proof. apply _Z_from_bytes_unsigned_le'_0s. Qed.

    Lemma _Z_from_bytes_le_0s:
      forall sgn (cnt: nat),
        _Z_from_bytes_le sgn (repeat 0%N cnt) = 0%Z.
    Proof.
      move=> [ | ] cnt; rewrite /_Z_from_bytes_le.
      - rewrite repeat_length _Z_from_bytes_unsigned_le_0s.
        assert (8 * N.of_nat cnt = 0 \/ 0 < 8 * N.of_nat cnt)%N as [Hcnt | Hcnt] by lia.
        + rewrite /to_signed_bits bool_decide_eq_true_2; by lia.
        + rewrite to_signed_bits_id; intuition; [by reflexivity | ].
          apply Z.pow_pos_nonneg; lia.
      - apply _Z_from_bytes_unsigned_le_0s.
    Qed.

    Lemma _Z_from_bytes_def_0s:
      forall endianness sgn (cnt: nat),
        _Z_from_bytes_def endianness sgn (repeat 0%N cnt) = 0%Z.
    Proof.
      move=> [ | ] sgn cnt; rewrite /_Z_from_bytes_def ?rev_repeat;
        apply _Z_from_bytes_le_0s.
    Qed.

    Lemma _Z_from_bytes_unsigned_le'_S_idx:
      forall (idx: nat) (bytes: list N),
        (_Z_from_bytes_unsigned_le' (S idx) (bytes) =
         _Z_from_bytes_unsigned_le' idx bytes ≪ 8)%Z.
    Proof.
      intros idx bytes; generalize dependent idx;
        induction bytes; intros=> //=.
      rewrite /_Z_from_bytes_unsigned_le' //=.
      fold (_Z_from_bytes_unsigned_le' (S (S idx)) bytes).
      fold (_Z_from_bytes_unsigned_le' (S idx) bytes).
      rewrite Z.shiftl_lor.
      by rewrite IHbytes _set_byte_S_idx.
    Qed.

    #[local] Lemma length_1_inv:
      forall {A} (l : list A),
        length l = 1%nat ->
        exists x0,
          l = [x0].
    Proof. intros; do 2 (try destruct l)=> //; do 1 eexists; eauto. Qed.
    #[local] Lemma length_2_inv:
      forall {A} (l : list A),
        length l = 2%nat ->
        exists x0 x1,
          l = [x0; x1].
    Proof. intros; do 3 (try destruct l)=> //; do 2 eexists; eauto. Qed.
    #[local] Lemma length_4_inv:
      forall {A} (l : list A),
        length l = 4%nat ->
        exists x0 x1 x2 x3,
          l = [x0; x1; x2; x3].
    Proof. intros; do 5 (try destruct l)=> //; do 4 eexists; eauto. Qed.
    #[local] Lemma length_8_inv:
      forall {A} (l : list A),
        length l = 8%nat ->
        exists x0 x1 x2 x3 x4 x5 x6 x7,
          l = [x0; x1; x2; x3; x4; x5; x6; x7].
    Proof. intros; do 9 (try destruct l)=> //; do 8 eexists; eauto. Qed.
    #[local] Lemma length_16_inv:
      forall {A} (l : list A),
        length l = 16%nat ->
        exists x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15,
          l = [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15].
    Proof. intros; do 17 (try destruct l)=> //; do 16 eexists; eauto. Qed.

    Lemma _Z_from_bytes_unsigned_le_bswap:
      forall bsz sz (bytes: list N) v,
        Datatypes.length bytes = sz ->
        bytesNat bsz = sz ->
        _Z_from_bytes_unsigned_le bytes = v ->
        _Z_from_bytes_unsigned_le (rev bytes) = bswap bsz v.
    Proof.
      rewrite /_Z_from_bytes_unsigned_le/_Z_from_bytes_unsigned_le';
        move=> bsz sz bytes v Hlen Hsz Hdecodes; destruct bsz;
        simpl in *; rewrite -Hsz in Hlen; subst;
        [ apply length_1_inv  in Hlen as [? Hbytes]
        | apply length_2_inv  in Hlen as [? [? Hbytes]]
        | apply length_4_inv  in Hlen as [? [? [? [? Hbytes]]]]
        | apply length_8_inv  in Hlen as [? [? [? [? [? [? [? [? Hbytes]]]]]]]]
        | apply length_16_inv in Hlen as [? [? [? [? [? [? [? [?
                                            [? [? [? [? [? [? [? [? Hbytes]]]]]]]]]]]]]]]]];
        rewrite Hbytes //= !Z.lor_0_r.
      - now rewrite bswap8_set_byte_reverse.
      - now rewrite bswap16_set_byte_reverse.
      - now rewrite bswap32_set_byte_reverse.
      - now rewrite bswap64_set_byte_reverse.
      - now rewrite bswap128_set_byte_reverse.
    Qed.

    Lemma _Z_from_bytes_unsigned_le'_singleton idx a :
      _Z_from_bytes_unsigned_le' idx [a] = (_set_byte (Z.of_N a) idx).
    Proof.
      rewrite/_Z_from_bytes_unsigned_le'.
      cbn.
      by rewrite Z.lor_0_r.
    Qed.

    Lemma _Z_from_bytes_unsigned_le'_bounds bytes idx b :
      (256 ^ (length bytes + Z.of_nat idx)%Z <= b)%Z ->
      (0 ≤ _Z_from_bytes_unsigned_le' idx bytes < b)%Z.
    Proof.
      move: b idx.
      elim bytes.
      {
        move => ? ?.
        rewrite Z.add_0_l.
        move => ?.
        split; [by []|].
        cbn.
        eapply Z.lt_le_trans.
        2: { eassumption. }
        apply Z.pow_pos_nonneg; [ by[] | ].
        exact: Zle_0_nat.
      }
      move => a l IH b idx /= H.
      rewrite _Z_from_bytes_unsigned_le'_cons.
      rewrite _Z_from_bytes_unsigned_le'_S_idx.
      assert (
          (0
             ≤ Z.lor (_Z_from_bytes_unsigned_le' idx [a]) (_Z_from_bytes_unsigned_le' idx l ≪ 8) <
             2 ^ (Z.of_N $ N.of_nat (8 * (S (length l) + idx))))%Z
        ) as H1.
      {
        apply ZlorRange.
        {
          rewrite _Z_from_bytes_unsigned_le'_singleton.
          move: (_set_byte_bound (Z.of_N a) idx) => [L0 L1].
          split; first assumption.
          eapply Z.lt_le_trans; first eassumption.
          apply Z.pow_le_mono_r; first done.
          lia.
        }
        move: (IH (2 ^ Z.of_N (N.of_nat (8 * (S (length l) + idx))))%Z (S idx)).
        rewrite _Z_from_bytes_unsigned_le'_S_idx.
        apply.
        rewrite nat_N_Z.
        rewrite Nat2Z.inj_mul.
        rewrite Z.pow_mul_r //.
        apply: Z.pow_le_mono.
        1: done.
        lia.
      }
      split; first tauto.
      eapply Z.lt_le_trans.
      {
        move: H1 => [_ max].
        eassumption.
      }
      rewrite nat_N_Z.
      rewrite Nat2Z.inj_mul.
      rewrite Z.pow_mul_r //.
      cbn.
      eapply Z.le_trans.
      2: eassumption.
      apply: Z.pow_le_mono.
      1: done.
      lia.
    Qed.

    Lemma _Z_from_bytes_unsigned_le_bounds bytes b :
      (256 ^ length bytes <= b)%Z ->
      (0 <= _Z_from_bytes_unsigned_le bytes < b)%Z.
    Proof.
      move => H.
      apply _Z_from_bytes_unsigned_le'_bounds.
      by rewrite Z.add_0_r.
    Qed.

  End FromBytesFacts_internal.

  Section FromToFacts_internal.
    #[local] Transparent _get_byte _set_byte.

    Lemma _Z_from_to_bytes_unsigned_le'_overflow:
      forall (idx cnt: nat) (v: Z),
        (2^(8*(idx+cnt)) <= v)%Z ->
        _Z_from_bytes_unsigned_le' idx (_Z_to_bytes_unsigned_le' idx cnt v) =
        Z.land ((Z.ones (8*cnt)) ≪ (8*idx)) v.
    Proof.
      intros idx cnt v Hlower;
        generalize dependent idx;
        generalize dependent v;
        induction cnt; intros=> //=.
      - rewrite /Z.ones Z.mul_0_r Z.shiftl_0_r
                _Z_to_bytes_unsigned_le'_0_bytes
                _Z_from_bytes_unsigned_le'_nil.
        by rewrite Z.shiftl_0_l Z.land_0_l.
      - rewrite _Z_to_bytes_unsigned_le'_S_cnt
                _Z_from_bytes_unsigned_le'_app
                _Z_to_bytes_unsigned_le'_length.
        rewrite [_Z_to_bytes_unsigned_le' _ 1 _]/_Z_to_bytes_unsigned_le' //=.
        rewrite [_Z_from_bytes_unsigned_le' _ [_]]/_Z_from_bytes_unsigned_le' //=.
        rewrite Z.lor_0_r.
        rewrite Z2N.id; [ | apply _get_byte_nonneg].
        rewrite _set_get_byte_roundtrip/_get_byte.
        assert (2^(8*(idx+cnt)) <= v)%Z as Hlower'. {
          etrans; last eapply Hlower;
            apply Z.pow_le_mono_r; lia.
        }
        specialize (IHcnt v idx Hlower'); rewrite IHcnt //=.
        apply Z.bits_inj'=> n ?.
        repeat (rewrite ?Z.lor_spec ?Z.land_spec; try lia).
        rewrite Z.shiftl_land -Z.ldiff_ones_r; try lia.
        repeat (rewrite ?Z.lor_spec ?Z.land_spec ?Z.shiftl_spec ?Z.ldiff_spec; try lia).
        rewrite !Z.testbit_ones; try lia.
        churn_bits'.
    Qed.

    Lemma _Z_from_to_bytes_unsigned_le'_roundtrip:
      forall (idx cnt: nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*(idx+cnt)))%Z ->
        _Z_from_bytes_unsigned_le' idx (_Z_to_bytes_unsigned_le' idx cnt v) =
        (v - v `mod` 2^(8*idx))%Z.
    Proof.
      intros idx cnt v Hlower Hupper;
        generalize dependent idx;
        generalize dependent v;
        induction cnt; intros=> //=.
      - rewrite Z.add_0_r in Hupper.
        rewrite _Z_to_bytes_unsigned_le'_0_bytes
                _Z_from_bytes_unsigned_le'_nil.
        rewrite Zmod_small; try intuition; lia.
      - assert (v < 2^(8*(idx+cnt)) \/ 2^(8*(idx+cnt)) <= v)%Z as [Hv | Hv] by lia.
        + rewrite _Z_to_bytes_unsigned_le'_S_cnt
                  _Z_from_bytes_unsigned_le'_app
                  _Z_to_bytes_unsigned_le'_length
                  IHcnt; try lia.
          rewrite _Z_to_bytes_unsigned_le'_small; try lia.
          1: by rewrite _Z_from_bytes_unsigned_le'_0s Z.lor_0_r.
        + clear IHcnt.
          rewrite Zmod_eq_full.
          2: pose proof (Z.pow_pos_nonneg
                           2 (8 * idx)
                           ltac:(lia) ltac:(lia)); lia.
          rewrite -Z.shiftr_div_pow2; try lia.
          rewrite -Z.shiftl_mul_pow2; try lia.
          rewrite -Z.ldiff_ones_r; try lia.
          rewrite _Z_to_bytes_unsigned_le'_S_cnt
                  _Z_from_bytes_unsigned_le'_app
                  _Z_to_bytes_unsigned_le'_length.
          rewrite Z.sub_sub_distr Z.sub_diag Z.add_0_l.
          rewrite [_Z_to_bytes_unsigned_le' _ 1 _]/_Z_to_bytes_unsigned_le' //=.
          rewrite [_Z_from_bytes_unsigned_le' _ [_]]/_Z_from_bytes_unsigned_le' //=.
          rewrite Z.lor_0_r.
          rewrite Z2N.id; [ | apply _get_byte_nonneg].
          rewrite _set_get_byte_roundtrip/_get_byte Z.shiftl_land.
          rewrite _Z_from_to_bytes_unsigned_le'_overflow; try lia.
          erewrite Z_ldiff_split; eauto; f_equal.
          rewrite -Z.ldiff_ones_r; try lia.
          rewrite Z.land_comm.

          apply Z.bits_inj'=> n ?.
          repeat (rewrite ?Z.lor_spec ?Z.land_spec ?Z.shiftl_spec ?Z.ldiff_spec; try lia).
          rewrite !Z.testbit_ones; try lia.
          churn_bits'.
    Qed.

    Lemma _Z_from_to_bytes_unsigned_le_roundtrip:
      forall (cnt: nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*cnt))%Z ->
        _Z_from_bytes_unsigned_le (_Z_to_bytes_unsigned_le cnt v) = v.
    Proof.
      intros cnt v Hlower Hupper.
      pose proof (_Z_from_to_bytes_unsigned_le'_roundtrip 0 cnt v Hlower) as Hpf.
      rewrite Z.add_0_l in Hpf.
      specialize (Hpf Hupper).
      rewrite /_Z_from_bytes_unsigned_le
              /_Z_to_bytes_unsigned_le Hpf.
      rewrite Z.mul_0_r Z.pow_0_r Zmod_1_r; lia.
    Qed.

    Lemma _get_set_later_bytes_irrelevant idx start lst :
      (idx < start)%nat ->
      _get_byte
          (foldr
            (λ '(idx0, byte) (acc : Z),
               (_set_byte (Z.of_N byte) idx0 `lor` acc)%Z) 0%Z
            (zip (seq start (length lst)) lst)) idx = 0%Z.
    Proof.
      move: idx start.
      induction lst.
      {
        move => ? ? ?.
        by rewrite _get_byte_0.
      }
      move => ? ? ?.
      cbn.
      rewrite _get_byte_lor.
      rewrite _get_set_byte_no_overlap.
      2: lia.
      rewrite Z.lor_0_l.
      apply: IHlst.
      lia.
    Qed.

    Lemma _get_byte_0_small_id (z : Z) :
      _get_byte z 0 = Z.modulo z 256.
    Proof. by rewrite/_get_byte /Z.of_nat Z.mul_0_r Z.shiftr_0_r Z.land_ones. Qed.

    Lemma _Z_to_from_bytes_unsigned_le'_roundtrip (bytes : list N) (idx cnt : nat) :
      Forall (λ b : N, (b < 256)%N) bytes →
      cnt = length bytes →
      _Z_to_bytes_unsigned_le' idx cnt (_Z_from_bytes_unsigned_le' idx bytes) = bytes.
    Proof.
      move: idx bytes.
      induction cnt.
      { by move => ? []. }
      move => idx [].
      { done. }
      move => hd tl smallH.
      apply Forall_cons_1 in smallH.
      move: smallH => [small_hdH small_tlH].
      move => [] cnt_eq.
      rewrite/_Z_to_bytes_unsigned_le'.
      cbn.
      f_equal.
      {
        rewrite _get_byte_lor _get_set_later_bytes_irrelevant.
        2: lia.
        rewrite Z.lor_0_r _get_set_byte_roundtrip _get_byte_0_small_id Z2N.inj_mod.
        2: lia.
        2: lia.
        by rewrite N2Z.id N.mod_small.
      }
      move: (IHcnt (S idx) tl small_tlH cnt_eq).
      rewrite /_Z_to_bytes_unsigned_le' /_Z_from_bytes_unsigned_le'.
      move => IH.
      rewrite -{3}IH.
      apply: map_ext_Forall.
      rewrite Forall_seq.
      move => ? ?.
      cbn.
      f_equal.
      rewrite _get_byte_lor _get_set_byte_no_overlap.
      2: lia.
      by rewrite Z.lor_0_l.
    Qed.

    Lemma _Z_to_from_bytes_unsigned_le_roundtrip (bytes : list N) (cnt : nat) :
      Forall (fun b => b < 256)%N bytes ->
      cnt = length bytes ->
      (_Z_to_bytes_unsigned_le cnt $ _Z_from_bytes_unsigned_le bytes) = bytes.
    Proof.
      move => ? ?.
      by rewrite/_Z_to_bytes_unsigned_le/_Z_from_bytes_unsigned_le
        _Z_to_from_bytes_unsigned_le'_roundtrip.
    Qed.

    Lemma _Z_from_to_bytes_le_roundtrip:
      forall (cnt: nat) (sgn: signed) (v: Z),
        match sgn with
        | Signed   => -2^((8*cnt)-1) <= v /\ v <= 2^((8*cnt)-1) - 1
        | Unsigned => 0 <= v /\ v < 2^(8*cnt)
        end%Z ->
        _Z_from_bytes_le sgn (_Z_to_bytes_le cnt sgn v) = v.
    Proof.
      destruct sgn; intros v [Hlower Hupper];
        [ | by apply _Z_from_to_bytes_unsigned_le_roundtrip].
      rewrite /_Z_from_bytes_le /_Z_to_bytes_le _Z_to_bytes_unsigned_le_length.
      assert (v < 0 \/ 0 <= v)%Z as [Hv | Hv] by lia.
      - rewrite _Z_from_to_bytes_unsigned_le_roundtrip.
        + apply to_signed_unsigned_bits_roundtrip; intuition;
            replace (Z.of_N (8 * N.of_nat cnt) - 1)%Z
              with (8 * cnt - 1)%Z; lia.
        + rewrite /trim; apply Z.mod_pos;
            apply Z.pow_pos_nonneg; lia.
        + rewrite /trim.
          replace (Z.of_N (8 * N.of_nat cnt))
            with (8 * cnt)%Z by lia.
          by pose proof (Z_mod_lt v (2^(8*cnt))%Z
                                   ltac:(apply Z.lt_gt; apply Z.pow_pos_nonneg; lia))
            as [? ?].
      - rewrite /trim Zmod_small; intuition; try lia.
        + rewrite _Z_from_to_bytes_unsigned_le_roundtrip; try lia.
          * apply to_signed_bits_id; intuition.
            eapply Z.le_lt_trans; eauto.
            replace (Z.of_N (8 * N.of_nat cnt) - 1)%Z
              with (8 * cnt - 1)%Z; lia.
          * eapply Z.le_lt_trans; eauto.
            match goal with
            | |- (_ < ?r)%Z => replace r with (r - 0)%Z by lia
            end.
            apply Z.sub_lt_le_mono; try apply Z.pow_lt_mono_r; lia.
        + eapply Z.le_lt_trans; eauto.
          match goal with
          | |- (_ < ?r)%Z => replace r with (r - 0)%Z by lia
          end.
          apply Z.sub_lt_le_mono; try apply Z.pow_lt_mono_r; lia.
    Qed.

    Lemma _Z_from_unsigned_to_signed_bytes_le:
      forall (cnt: nat) (v: Z),
        (-2^((8*cnt)-1) <= v)%Z ->
        (v <= 2^((8*cnt)-1) - 1)%Z ->
        _Z_from_bytes_le Unsigned (_Z_to_bytes_le cnt Signed v) =
        to_unsigned_bits (8*N.of_nat cnt) v.
    Proof.
      move=> cnt v Hlower Hupper.
      rewrite /trim /_Z_from_bytes_le /_Z_to_bytes_le.
      rewrite _Z_from_to_bytes_unsigned_le_roundtrip /trim //.
      - apply Z_mod_lt; rewrite Z.gt_lt_iff;
          apply Z.pow_pos_nonneg; lia.
      - replace (Z.of_N (8 * N.of_nat cnt)) with (8 * cnt)%Z by lia;
          apply Z_mod_lt; rewrite Z.gt_lt_iff;
          apply Z.pow_pos_nonneg; lia.
    Qed.

    Lemma _Z_from_signed_to_unsigned_bytes_le:
      forall (cnt: nat) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*cnt))%Z ->
        _Z_from_bytes_le Signed (_Z_to_bytes_le cnt Unsigned v) =
        to_signed_bits (8*N.of_nat cnt) v.
    Proof.
      move=> cnt v Hlower Hupper.
      rewrite /_Z_from_bytes_le /_Z_to_bytes_le
              _Z_to_bytes_unsigned_le_length
              _Z_from_to_bytes_unsigned_le_roundtrip //.
    Qed.

    Lemma _Z_from_to_bytes_def_roundtrip:
      forall (cnt: nat) (endianness: endian) (sgn: signed) (v: Z),
        match sgn with
        | Signed   => -2^((8*cnt)-1) <= v /\ v <= 2^((8*cnt)-1) - 1
        | Unsigned => 0 <= v /\ v < 2^(8*cnt)
        end%Z ->
        _Z_from_bytes_def endianness sgn (_Z_to_bytes_def cnt endianness sgn v) = v.
    Proof.
      rewrite /_Z_from_bytes_def /_Z_to_bytes_def;
        intros cnt [ | ] sgn v H;
        try rewrite rev_involutive;
        by apply _Z_from_to_bytes_le_roundtrip.
    Qed.

    Lemma _Z_to_from_bytes_le_round_trip sgn cnt bytes :
      Forall (λ b : N, (b < 256)%N) bytes ->
      cnt = length bytes ->
      _Z_to_bytes_le cnt sgn (_Z_from_bytes_le sgn bytes) = bytes.
    Proof.
      move => small cntH.
      move: sgn => [].
      2: {
        cbn.
        rewrite/_Z_to_bytes_le.
        by apply: _Z_to_from_bytes_unsigned_le_roundtrip.
      }
      rewrite/_Z_to_bytes_le.
      cbn.
      rewrite !cntH.
      rewrite trim_to_signed_bits_agree.
      rewrite to_unsigned_bits_id.
      { by apply: _Z_to_from_bytes_unsigned_le_roundtrip. }
      apply: _Z_from_bytes_unsigned_le_bounds.
      set bits := (match N.of_nat _ with 0%N => _ | N.pos _ => _ end).
      rewrite -(Z.pow_mul_r 2 8).
      2: done.
      2: lia.
      rewrite/bits.
      apply: Z.eq_le_incl.
      f_equal.
      rewrite -nat_N_Z.
      case (N.of_nat (length bytes)).
      { lia. }
      move => ?.
      lia.
    Qed.

    Lemma _Z_to_from_bytes_def_roundtrip bytes sgn endianness cnt :
      Forall (λ b : N, (b < 256)%N) bytes →
      cnt = length bytes →
      _Z_to_bytes_def cnt endianness sgn (_Z_from_bytes_def endianness sgn bytes) = bytes.
    Proof.
      move => small cntH.
      rewrite/_Z_from_bytes_def/_Z_to_bytes_def.
      move: endianness => [].
      { exact: _Z_to_from_bytes_le_round_trip. }
      rewrite _Z_to_from_bytes_le_round_trip.
      { exact: rev_involutive. }
      { exact: Forall_rev. }
      by rewrite rev_length.
    Qed.

    Lemma _Z_from_unsigned_to_signed_bytes_def:
      forall (cnt: nat) (endianness: endian) (v: Z),
        (-2^((8*cnt)-1) <= v)%Z ->
        (v <= 2^((8*cnt)-1) - 1)%Z ->
        _Z_from_bytes_def endianness Unsigned (_Z_to_bytes_def cnt endianness Signed v) =
        to_unsigned_bits (8*N.of_nat cnt) v.
    Proof.
      rewrite /_Z_from_bytes_def /_Z_to_bytes_def;
        intros cnt [ | ] v Hlower Hupper;
        try rewrite rev_involutive;
        by apply _Z_from_unsigned_to_signed_bytes_le.
    Qed.

    Lemma _Z_from_signed_to_unsigned_bytes_def:
      forall (cnt: nat) (endianness: endian) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*cnt))%Z ->
        _Z_from_bytes_def endianness Signed (_Z_to_bytes_def cnt endianness Unsigned v) =
        to_signed_bits (8*N.of_nat cnt) v.
    Proof.
      rewrite /_Z_from_bytes_def /_Z_to_bytes_def;
        intros cnt [ | ] v Hlower Hupper;
        try rewrite rev_involutive;
        by apply _Z_from_signed_to_unsigned_bytes_le.
    Qed.

    Lemma _Z_from_bytes_Big_Unsigned_bound_internal:
      forall lst,
        (0 <= _Z_from_bytes_def Big Unsigned (rev lst) < 256 ^ (length $ rev lst))%Z.
    Proof.
      rewrite/_Z_from_bytes_def.
      rewrite/_Z_from_bytes_le.
      move => lst.
      apply _Z_from_bytes_unsigned_le_bounds.
      by rewrite !rev_length.
    Qed.
  End FromToFacts_internal.

  Section ToBytes_external.
    Definition _Z_to_bytes_aux : seal (_Z_to_bytes_def). Proof. by eexists. Qed.
    Definition _Z_to_bytes := _Z_to_bytes_aux.(unseal).
    Definition _Z_to_bytes_eq: _Z_to_bytes = _ := _Z_to_bytes_aux.(seal_eq).
  End ToBytes_external.

  Section ToBytesFacts_external.
    Lemma _Z_to_bytes_length:
      forall (cnt: nat) endianness sgn v,
        length (_Z_to_bytes cnt endianness sgn v) = cnt.
    Proof. move=> *; rewrite _Z_to_bytes_eq; apply _Z_to_bytes_def_length. Qed.
    Lemma _Z_to_bytes_lengthN:
      forall (cnt: nat) endianness sgn v,
        lengthN (_Z_to_bytes cnt endianness sgn v) = N.of_nat cnt.
    Proof.
      intros.
      by rewrite/lengthN _Z_to_bytes_length.
    Qed.

    Lemma _Z_to_bytes_0_bytes:
      forall sgn endianness v,
        _Z_to_bytes 0 endianness sgn v = [].
    Proof. move=> *; rewrite _Z_to_bytes_eq; apply _Z_to_bytes_def_0_bytes. Qed.

    Lemma _Z_to_bytes_0_value:
      forall (cnt: nat) endianness sgn,
        _Z_to_bytes cnt endianness sgn 0%Z = repeat 0%N cnt.
    Proof. move=> *; rewrite _Z_to_bytes_eq; apply _Z_to_bytes_def_0_value. Qed.

    Lemma _Z_to_bytes_unsigned_le_range cnt v :
      Forall (λ v : N, (v < 256)%N) (_Z_to_bytes_unsigned_le cnt v).
    Proof.
      rewrite/_Z_to_bytes_unsigned_le/_Z_to_bytes_unsigned_le'.
      rewrite Forall_map.
      apply: Forall_true.
      move => x.
      move: (_get_byte_bound v x).
      cbn.
      lia.
    Qed.

    Lemma _Z_to_bytes_le_range z cnt sign :
      Forall (λ v : N, v < 256)%N (_Z_to_bytes_le cnt sign z).
    Proof.
      rewrite/_Z_to_bytes_le.
      move: sign => []; exact: _Z_to_bytes_unsigned_le_range.
    Qed.

    Lemma _Z_to_bytes_range z cnt endianness sign:
      Forall (λ v : N, v < 256)%N (_Z_to_bytes cnt endianness sign z).
    Proof.
      rewrite _Z_to_bytes_eq/_Z_to_bytes_def.
      move: endianness => [].
      { exact: _Z_to_bytes_le_range. }
      apply: Forall_rev.
      exact: _Z_to_bytes_le_range.
    Qed.

  End ToBytesFacts_external.

  Section FromBytes_external.
    Definition _Z_from_bytes_aux: seal _Z_from_bytes_def. Proof. by eexists. Qed.
    Definition _Z_from_bytes := _Z_from_bytes_aux.(unseal).
    Definition _Z_from_bytes_eq: @_Z_from_bytes = _ := _Z_from_bytes_aux.(seal_eq).
  End FromBytes_external.

  Section FromBytesFacts_external.
    Lemma _Z_from_bytes_nil:
      forall endianness sgn,
        _Z_from_bytes endianness sgn [] = 0%Z.
    Proof. move=> *; rewrite _Z_from_bytes_eq; apply _Z_from_bytes_def_nil. Qed.

    Lemma _Z_from_bytes_0s:
      forall endianness sgn (cnt: nat),
        _Z_from_bytes endianness sgn (repeat 0%N cnt) = 0%Z.
    Proof. move=> *; rewrite _Z_from_bytes_eq; apply _Z_from_bytes_def_0s. Qed.
    Lemma _Z_to_bytes_Big_Unsigned_bound:
      forall lst,
        (0 <= _Z_from_bytes Big Unsigned lst < 256 ^ (length lst))%Z.
    Proof.
      move => lst.
      rewrite -[lst]rev_involutive.
      rewrite _Z_from_bytes_eq.
      exact: _Z_from_bytes_Big_Unsigned_bound_internal.
    Qed.
    Lemma _Z_to_bytes_Big_Unsigned_boundN:
      forall lst,
        (0 <= _Z_from_bytes Big Unsigned lst < 256 ^ (lengthN lst))%Z.
    Proof.
      move=> *; rewrite/lengthN length_lengthN Nat2N.id nat_N_Z.
      exact: _Z_to_bytes_Big_Unsigned_bound.
    Qed.
  End FromBytesFacts_external.

  Section FromToFacts_external.
    Lemma _Z_from_to_bytes_roundtrip:
      forall (cnt: nat) (endianness: endian) (sgn: signed) (v: Z),
        match sgn with
        | Signed   => -2^((8*cnt)-1) <= v /\ v <= 2^((8*cnt)-1) - 1
        | Unsigned => 0 <= v /\ v < 2^(8*cnt)
        end%Z ->
        _Z_from_bytes endianness sgn (_Z_to_bytes cnt endianness sgn v) = v.
    Proof.
      move=> *; rewrite _Z_from_bytes_eq _Z_to_bytes_eq;
        by apply _Z_from_to_bytes_def_roundtrip.
    Qed.

    Lemma _Z_to_from_bytes_roundtrip bytes sgn endianness cnt :
      Forall (λ b : N, (b < 256)%N) bytes →
      cnt = length bytes →
      _Z_to_bytes cnt endianness sgn (_Z_from_bytes endianness sgn bytes) = bytes.
    Proof.
      move=> *; rewrite _Z_from_bytes_eq _Z_to_bytes_eq;
        by apply _Z_to_from_bytes_def_roundtrip.
    Qed.

    Lemma _Z_from_unsigned_to_signed_bytes:
      forall (cnt: nat) (endianness: endian) (v: Z),
        (-2^((8*cnt)-1) <= v)%Z ->
        (v <= 2^((8*cnt)-1) - 1)%Z ->
        _Z_from_bytes endianness Unsigned (_Z_to_bytes cnt endianness Signed v) =
        to_unsigned_bits (8*N.of_nat cnt) v.
    Proof.
      move=> *; rewrite _Z_from_bytes_eq _Z_to_bytes_eq;
        by apply _Z_from_unsigned_to_signed_bytes_def.
    Qed.

    Lemma _Z_from_signed_to_unsigned_bytes:
      forall (cnt: nat) (endianness: endian) (v: Z),
        (0 <= v)%Z ->
        (v < 2^(8*cnt))%Z ->
        _Z_from_bytes endianness Signed (_Z_to_bytes cnt endianness Unsigned v) =
        to_signed_bits (8*N.of_nat cnt) v.
    Proof.
      move=> *; rewrite _Z_from_bytes_eq _Z_to_bytes_eq;
        by apply _Z_from_signed_to_unsigned_bytes_def.
    Qed.
  End FromToFacts_external.
End FromToBytes.


Set Implicit Arguments.
Require Import RelationClasses Morphisms List
        Omega Init.Nat Setoid std calculus unification.
Require Import third_order.pcp third_order.encoding.
Import ListNotations.

Definition MPCP' '(c, C) :=
  exists I, I ⊆ nats (length C) /\
       hd c ++ @concat symbol (select I (heads C)) = tl c ++ concat (select I (tails C)).

Lemma MPCP_MPCP' c C: MPCP (c, C) <-> MPCP' (c, c::C).
Proof. firstorder. Qed.

(** * Simplified Reduction *)
Section MPCP_U3.

  Variable (X: Const).

  Definition redtm (w: word) (W: list word): exp X :=
    lambda lambda (enc 0 1 w) (AppR (var 2) (Enc 0 1 W)).
  Definition redctx (n: nat)  := [Arr (repeat (alpha → alpha) n) alpha].

  Lemma redtm_typing w W:
    redctx (length W) ⊢(3) redtm w W : (alpha → alpha) → (alpha → alpha) →  alpha.
  Proof.
    unfold redctx; do 3 econstructor.
    - eapply enc_typing; eauto.
    - eapply AppR_ordertyping;[ eapply Enc_typing|]; simplify;
        econstructor; cbn; simplify; eauto.
  Qed.

  (** ** Reduction Function *)
  Program Instance MPCP'_to_U P : orduni 3 X :=
    {
      Gamma₀ :=  redctx (length (snd P));
      s₀ :=  redtm (hd (fst P)) (heads (snd P));
      t₀ :=  redtm (tl (fst P)) (tails (snd P));
      A₀ := (alpha → alpha) → (alpha → alpha) →  alpha;
      H1₀ := redtm_typing (hd (fst P)) (heads (snd P));
      H2₀ := redtm_typing (tl (fst P)) (tails (snd P));
    }.
  Next Obligation. now simplify. Qed.
  Next Obligation. now simplify. Qed.

    (** ** Forward Direction *)
    Lemma MPCP'_U3 P: MPCP' P -> OU 3 X (MPCP'_to_U P).
    Proof.
      destruct P as [c C]; intros (I & Sub & EQ).
      exists [alpha]. exists (finst I (length C) .: var); split.
        - intros x A. destruct x as [| [|]]; try discriminate; cbn.
          injection 1 as ?; subst.
          eapply finst_typing; eauto.
        - cbn -[enc]. rewrite !enc_subst_id; eauto.
          rewrite !AppR_subst; rewrite ?Enc_subst_id; eauto; cbn.
          all: cbn; rewrite !ren_plus_base, !ren_plus_combine;
            change (1 + 1) with 2.
          replace (|C|) with (|map hd C|) at 1 by now simplify.
          replace (|C|) with (|map tl C|) at 1 by now simplify.
          rewrite !finst_equivalence, <-!enc_app, EQ.
          all: now simplify.
    Qed.

    (** ** Backward Direction *)
    Lemma U3_MPCP' P:
      NOU 3 (MPCP'_to_U P) -> MPCP' P.
    Proof. destruct P as [c C].
      intros (Delta & sigma & T1 & EQ & N); cbn -[enc] in EQ.
      rewrite !enc_subst_id in EQ; eauto.
      rewrite !AppR_subst in EQ; rewrite !Enc_subst_id in EQ; eauto; cbn in EQ; unfold funcomp in EQ.
      repeat eapply equiv_lam_elim in EQ.
      rewrite !ren_plus_base, !ren_plus_combine in *; change (1 + 1) with 2 in *.
      specialize (T1 0 (Arr (repeat (alpha → alpha) (length C)) alpha)); mp T1; eauto.
      specialize (N 0) as N1. eapply normal_nf in N1 as N2. destruct N2 as [k a ? T _ isA ->].
      eapply Lambda_ordertyping_inv in T1 as (L & B & H0 & H1 & <-).
      eapply id in H0 as T2.
      assert (|L | <= |C|) as L1 by
            (eapply (f_equal arity) in H1; simplify in H1; rewrite H1; eauto).
      symmetry in H1; eapply Arr_inversion in H1 as (L2 & H1 & H2); simplify; try omega.
      edestruct (@list_decompose_alt  (|L|) _ C) as (C1 & C2 & H4 & H5); try omega; subst C.
      eapply repeated_app_inv in H1 as (H1 & H3 & H4); eauto.
      rewrite H4 in H2; subst B. rewrite H3 in *; simplify in *. assert (|L2| = |C1|) by omega.
      clear H1 H3 H4 L1. revert H0 H H5 EQ T2 N1.
      generalize (length L); generalize (length L2); clear L L2. intros l k H0 H H5 EQ T2 N2. subst.
      rewrite !Lambda_ren in EQ; simplify in EQ. rewrite !AppR_app in EQ.
      rewrite !AppR_Lambda' in EQ; simplify; eauto.
      rewrite !it_up_var_sapp in EQ; simplify; intros; unfold shift; try omega.
      destruct C1.
      - destruct (@AppL_largest _ (fun s => match s with var x => x < |C2| | _ => False end) (AppR a T))
        as (S & t & H1 & H2 & H3). intros []; intuition; now right.
        assert (exists I, I ⊆ nats (|C2|) /\ S = map var I) as [I []]. {
          clear H2. induction S. exists nil; cbn; intuition.
          edestruct IHS as [I]; [firstorder|]. intuition; subst.
          specialize (H1 a0); mp H1; [firstorder|].
          destruct a0 as [i| | |]; intuition. exists (i :: I); cbn.
          eapply lt_nats in H1. intuition. }
        clear H1. rewrite H2 in *. subst S. cbn -[add] in EQ.
        rewrite !AppL_subst in EQ.
        rewrite !select_variables_subst in EQ.
        all: unfold dom; simplify; eauto using nats_lt.
        cbn in T2; eapply AppL_ordertyping_inv in T2 as (L' & B & H8 & H9).
        assert (normal t) by now eapply normal_AppL_right, normal_Lambda, N2.
        rewrite <-!select_map, !enc_concat, <-!enc_app, !select_map in EQ.
        eapply enc_eq in EQ; eauto. exists I; intuition.
        1 - 4: intros ? EQ3;
            eapply end_is_var_typed in EQ3 as (? & ? & ? & ?); cbn; simplify.
        (* close False goals *)
        1, 6, 11, 16: eapply H3; cbn; eauto; cbn; now simplify in *.
        (* close normal term goals *)
        2, 6, 10, 14: eauto.
        (* close Enc goals *)
        2, 5, 8, 11: reflexivity.
        (* close typing goals *)
        2, 4, 6, 8: eauto.
        (* close var goals *)
        1 - 4: intros; cbn; unfold funcomp; intuition discriminate.
      - rewrite AppR_subst in EQ.
        destruct a as [y| d | |]; cbn in isA; intuition; [destruct (le_lt_dec (length C2) y)|].
        + asimpl in EQ. rewrite !sapp_ge_in in EQ; simplify; eauto.
          eapply enc_eq in EQ; eauto.
           2 - 5: cbn; intros ? EQ' % equiv_head_equal; cbn; simplify; cbn; auto 1.
           2 - 5: revert EQ'; cbn; simplify; cbn; discriminate.
            exists nil; intuition; cbn; now simplify.
        + eapply AppR_ordertyping_inv in T2 as [? [_ T2]]; intuition. inv T2.
          eapply id in H2 as HH; rewrite nth_error_app1, nth_error_repeated in HH; simplify; eauto.
          injection HH as HH. eapply (f_equal ord) in HH. simplify in HH.
          symmetry in HH; eapply Nat.eq_le_incl in HH; simplify in HH.
          intuition. cbn in H6. omega.
        + asimpl in EQ. eapply enc_eq in EQ; eauto.
          2 - 5: cbn; intros ? EQ' % equiv_head_equal; cbn; simplify; cbn; auto 1.
          2 - 5: revert EQ'; cbn; simplify; discriminate.
          exists nil; intuition; cbn; now simplify.
    Qed.

End MPCP_U3.

Lemma MPCP_U3 X: MPCP ⪯ OU 3 X.
Proof.
  exists (fun '(c, C) => MPCP'_to_U X (c, c::C)). intros [c C]; rewrite MPCP_MPCP'; split.
  2: rewrite OU_NOU; eauto.
  all: eauto using MPCP'_U3, U3_MPCP'.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^384 - 317
Base: 48
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 48;
    bitwidth := 64;
    s := 2^384;
    c := [(1, 317)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Program.Syntax.
Require Export ZArith.
Require Import Coq.Program.Basics.
Require Import SetoidTactics.
Require Import SetoidClass.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.

Require Import HDI.Util.
Require Import HDI.Syntax.
Require Import HDI.Heap.
Require Import HDI.OpSem.
Require Import HDI.Bisimulation.
Require Import HDI.Safety.
Require Export HDI.Predicates.

Local Open Scope Z.
Local Open Scope stmt.

  Definition hoare_double (x: predicate heap) (s: stmt) :=
    forall h, h |= x -> safe h s.

  Notation "|-{{ x }} s" :=
    (hoare_double x%pred s%stmt)
    (no associativity, at level 65, s at level 42).

  Lemma hd_weaken: forall x y s,
    |-{{y}}  s ->
    x |-- y ->
    |-{{x}}  s.
  Proof.
    unfold hoare_double.
    intuition auto.
  Qed.

  Add Parametric Morphism : hoare_double
    with signature entails --> eq ==> impl
    as hd_d.
  Proof. firstorder. Qed.

  Lemma hd_exists: forall A x s,
    (forall a:A, |-{{x a}}  s) ->
    |-{{Ex_ a:A, x a}}  s.
  Proof. firstorder. Qed.

  Lemma hd_forall: forall A (a:A) x s,
    |-{{x a}}  s ->
    |-{{All_ a:A, x a}}  s.
  Proof. firstorder. Qed.

  Lemma ret_ok: forall v F k,
    |-{{F}}  k v ->
    |-{{F}}  x <- ret v; k x.
  Proof.
    unfold hoare_double; auto with safe.
  Qed.

  Lemma read_ok: forall a v F k,
    |-{{a |-> v && F}}  k v ->
    |-{{a |-> v && F}}  x <- read a; k x.
  Proof.
    unfold hoare_double; eauto with safe pred.
  Qed.

  Definition pred_free (x: predicate heap) (a:Z) :=
    forall h v, h |= x -> upd_heap h a v |= x.

  Lemma write_ok: forall a v v0 F k,
    pred_free F a ->
    |-{{a |-> v && F}}  k 1 ->
    |-{{a |-> v0 && F}}  write a v >>= k.
  Proof.
    unfold hoare_double; eauto with safe pred.
    intros.
    eapply safe_write;
      [ firstorder | eauto with pred ].
  Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj7synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus lv0 lv1)) (plus lv2 Zero)).
Admitted.
QuickChick conj7synthconj4.


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

Require Import Utf8.
Add LoadPath "/Users/danielle/projects/software-foundations/".
Require Import notations.

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


Require Import Fiat.ADT Fiat.ADTNotation.
Require Export Fiat.Computation.FixComp.

Import LeastFixedPointFun.

Instance refineFun_Reflexive fDom fCod : Reflexive (@refineFun fDom fCod).
Proof.
  intro x.
  induction fDom; simpl; intros.
  reflexivity.
  simpl in x.
  apply IHfDom.
Qed.

Add Parametric Morphism fDom fCod : (@refineFun fDom fCod)
    with signature
    ((@refineFun fDom fCod) --> (@refineFun fDom fCod) ++> impl)
      as refineFun_refineFun.
Proof.
  unfold impl; intros.
  induction fDom; simpl in *; intros.
  rewrite H, H1, H0.
  reflexivity.
  specialize (IHfDom (x t) (y t) (H t) (x0 t) (y0 t)).
  firstorder.
Qed.

Add Parametric Morphism fDom fCod : (@refineFun fDom fCod)
    with signature
    ((@refineFun fDom fCod) ==> Basics.flip (@refineFun fDom fCod)
                            ==> Basics.flip impl)
      as refineFun_refineFun_flip.
Proof.
  unfold impl; intros.
  induction fDom; simpl in *; intros.
  rewrite H, H1; assumption.
  specialize (IHfDom (x t) (y t) (H t) (x0 t) (y0 t)).
  firstorder.
Qed.

Instance refineFun_Transitive fDom fCod : Transitive (@refineFun fDom fCod).
Proof.
  intros x y z H1 H2.
  rewrite H1.
  exact H2.
Qed.

Program Instance refineFun_PreOrder fDom fCod : PreOrder (@refineFun fDom fCod).

Definition refineFunEquiv
           {fDom : list Type}
           {fCod : Type}
           (old new : funType fDom fCod) :=
  refineFun old new /\ refineFun new old.

Add Parametric Morphism fDom fCod
  : (@refineFun fDom fCod)
    with signature
    (@refineFunEquiv fDom fCod) --> (@refineFunEquiv fDom fCod) ++> impl
      as refineFun_refineFunEquiv.
Proof.
  unfold impl, refineFunEquiv; intros.
  intuition.
  rewrite H2, H1.
  assumption.
Qed.

Add Parametric Morphism fDom fCod
  : (@refineFun fDom fCod)
    with signature
    (@refineFunEquiv fDom fCod --> @refineFunEquiv fDom fCod
                     --> Basics.flip impl)
      as refineFun_refineFunEquiv'.
Proof.
  unfold impl, refineFunEquiv; intros.
  intuition.
  rewrite H3, H1.
  assumption.
Qed.

Program Instance refineFunEquiv_Equivalence fDom fCod :
  Equivalence (@refineFunEquiv fDom fCod).
Obligation 1.
unfold refineFunEquiv.
intro x.
split; reflexivity.
Defined.
Obligation 2.
unfold refineFunEquiv.
intros x y H.
intuition.
Qed.
Obligation 3.
unfold refineFunEquiv.
intros x y z H1 H2.
intuition.
transitivity y; trivial.
transitivity y; trivial.
Qed.

Instance refineFun_refineFunEquiv_subrelation fDom fCod :
  subrelation (@refineFunEquiv fDom fCod) (@refineFun fDom fCod).
Proof. intros ? ? [? ?]; assumption. Qed.

Lemma length_wf' : forall A len l,
    length l < len -> Acc (fun l1 l2 : list A => length l1 < length l2) l.
Proof.
  induction len; simpl; intros;
    constructor; intros.
  contradiction (NPeano.Nat.nlt_0_r _ H).
  apply IHlen.
  Require Import Omega.
  omega.
Qed.

Lemma length_wf : forall A,
    well_founded (fun l1 l2 : list A => length l1 < length l2).
Proof.
  red; intros; eapply length_wf'; eauto.
Qed.

(* Definition funType_to_methodType
           {rep : Type} {dom : list Type} {cod : Type} :
  funType (rep :: dom) (rep * cod) -> methodType rep dom (Some cod).
Proof.
  simpl; intro f.
  intro r'.
  specialize (f r'); clear r'.
  induction dom; simpl in *.
  exact f.
  intro r'.
  exact (IHdom (f r')).
Defined.

Definition methodType_to_funType
           {rep : Type} {dom : list Type} {cod : Type} :
  methodType rep dom (Some cod) -> funType (rep :: dom) (rep * cod).
Proof.
  simpl; intro f.
  intro r'.
  specialize (f r'); clear r'.
  induction dom; simpl in *.
  exact f.
  intro r'.
  exact (IHdom (f r')).
Defined.

Lemma methodType_to_funType_id
      {rep : Type} {dom : list Type} {cod : Type}
      (f : funType (rep :: dom) (rep * cod)) :
  methodType_to_funType (funType_to_methodType f) = f.
Proof.
  unfold methodType_to_funType, funType_to_methodType.
  extensionality r.
  induction dom; simpl in f;
    extensionality x; simpl.
  reflexivity.
  exact (IHdom (fun r => f r x)).
Qed. *)

Import EqNotations.

Require Import Fiat.Common.Frame.

Inductive hetero {A : Type} {B : A -> Type} : list A -> Type :=
| hnil : hetero []
| hcons x xs : hetero xs -> B x -> hetero (x :: xs).

Ltac under_fDom :=
  match goal with
  | [ fDom : list Type |- _ ] =>
    induction fDom; simpl in *;
    [| intros;
       repeat
         match goal with
         | [ f : ?OLDREP -> ?A -> funType ?FDOM ?FCOD |- _ ] =>
           match goal with
             [ IHfDom : (OLDREP -> funType FDOM FCOD) -> _,
                        x : A |- _ ] =>
             specialize (IHfDom (fun r => f r x));
             try exact IHfDom;
             try clear f
           end
         | [ f : ?OLDREP -> ?A -> methodType' ?OLDREP ?FDOM ?FCOD |- _ ] =>
           match goal with
             [ IHfDom : (OLDREP -> methodType' OLDREP FDOM FCOD) -> _,
                        x : A |- _ ] =>
             specialize (IHfDom (fun r => f r x));
             try exact IHfDom;
             try clear f
           end
         | [ f : ?A -> funType ?FDOM ?FCOD |- _ ] =>
           match goal with
             [ IHfDom : funType FDOM FCOD -> _,
                        x : A |- _ ] =>
             specialize (IHfDom (f x));
             try exact IHfDom;
             try clear f
           end
         end ]
  end.

Definition funApply {fDom fCod} :
  funType fDom fCod -> hetero (B:=id) fDom -> Comp fCod.
Proof.
  intros.
  induction fDom; simpl in *.
  exact X.
  inversion X0.
  exact (IHfDom (X X2) X1).
Defined.

Definition dom_old_to_new {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop) :
  funType (oldRep :: fDom) fCod -> funType (newRep :: fDom) fCod.
Proof.
  simpl; intros f r_n.
  induction fDom; simpl in *.
  exact ({ v | forall (r_o : oldRep),
               AbsR r_o r_n -> computes_to (f r_o) v}).
  exact (fun x => IHfDom (fun r => f r x)).
Defined.

Definition cod_old_to_new {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop) :
  funType fDom (oldRep * fCod) -> funType fDom (newRep * fCod).
Proof.
  simpl; intros f.
  induction fDom; simpl in *.
  exact { o : newRep * fCod |
          exists p,
          computes_to f (p, snd o) /\ AbsR p (fst o)}.
  intro x.
  exact (IHfDom (f x)).
Defined.

Definition dom_new_to_old {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop) :
  funType (newRep :: fDom) fCod -> funType (oldRep :: fDom) fCod.
Proof.
  simpl; intros f r_o.
  induction fDom; simpl in *.
  exact ({ v | forall (r_n : newRep),
               AbsR r_o r_n /\ computes_to (f r_n) v}).
  intro x.
  exact (IHfDom (fun r => f r x)).
Defined.

Definition cod_new_to_old {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop) :
  funType fDom (newRep * fCod) -> funType fDom (oldRep * fCod).
Proof.
  simpl; intros f.
  induction fDom; simpl in *.
  exact { o : oldRep * fCod |
          forall r_n',
            computes_to f (r_n', snd o) -> AbsR (fst o) r_n'}.
  intro x.
  exact (IHfDom (f x)).
Defined.

Definition domcod_old_to_new {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop) :
  funType (oldRep :: fDom) (oldRep * fCod) ->
  funType (newRep :: fDom) (newRep * fCod) :=
  fun k => dom_old_to_new AbsR (cod_old_to_new AbsR k).

Definition domcod_new_to_old {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop) :
  funType (newRep :: fDom) (newRep * fCod) ->
  funType (oldRep :: fDom) (oldRep * fCod) :=
  fun k => dom_new_to_old AbsR (cod_new_to_old AbsR k).

Definition funType_join {fDom fCod} :
  Comp (funType fDom fCod) -> funType fDom fCod.
Proof.
  intros.
  induction fDom.
  exact (v <- X; v).
  intro x.
  exact (IHfDom (f <- X; ret (f x))).
Defined.

Require Import
        Fiat.ADTRefinement
        Fiat.ADTRefinement.BuildADTRefinements.

Fixpoint refineFun_AbsR'
         {oldRep newRep}
         (fDom : list Type)
         (fCod : Type)
         (AbsR : oldRep -> newRep -> Prop)
         (fDef : funType fDom (oldRep * fCod))
         (fDef' : funType fDom (newRep * fCod))
         {struct fDom} : Prop :=
  match fDom as fDom'
        return funType fDom' (oldRep * fCod)
               -> funType fDom' (newRep * fCod) -> Prop
  with
  | List.nil =>
    fun fDef fDef' => refine (cod_old_to_new AbsR fDef) fDef'
  | List.cons T fDom' =>
    fun fDef fDef' =>
      forall (t : T), refineFun_AbsR' fDom' fCod AbsR (fDef t) (fDef' t)
  end fDef fDef'.

Definition refineFun_AbsR
           {oldRep newRep}
           (AbsR : oldRep -> newRep -> Prop)
           {fDom : list Type}
           {fCod : Type}
           (fDef : funType (oldRep :: fDom) (oldRep * fCod))
           (fDef' : funType (newRep :: fDom) (newRep * fCod)) : Prop :=
  forall r_o r_n, AbsR r_o r_n
                  -> refineFun_AbsR' fDom fCod AbsR (fDef r_o) (fDef' r_n).

Lemma refineFun_AbsR_trans
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef fDef'' : funType (oldRep :: fDom) (oldRep * fCod))
           (fDef' : funType (newRep :: fDom) (newRep * fCod)),
    refineFun fDef fDef''
    -> refineFun_AbsR AbsR fDef'' fDef'
    -> refineFun_AbsR AbsR fDef fDef'.
Proof.
  intros.
  unfold refineFun_AbsR in *.
  induction fDom; simpl in *; intros.
  { rewrite <- H0; eauto.
    unfold refine; intros; eauto.
    computes_to_inv; subst; destruct_ex; intuition.
    eapply H in H3; eauto.
  }
  apply (IHfDom (fun r => fDef r t)
                (fun r => fDef'' r t)
                (fun r => fDef' r t)); eauto.
Qed.

Lemma refineFun_AbsR'_trans
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef fDef'' : funType fDom (oldRep * fCod))
           (fDef' : funType fDom (newRep * fCod)),
    refineFun fDef fDef''
    -> refineFun_AbsR' _ _ AbsR fDef'' fDef'
    -> refineFun_AbsR' _ _ AbsR fDef fDef'.
Proof.
  intros.
  induction fDom; simpl in *; intros; eauto.
  rewrite <- H0; eauto.
  unfold refine; intros; computes_to_inv;
    destruct_ex; intuition eauto.
Qed.

Lemma refineFun_AbsR_trans'
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef : funType (oldRep :: fDom) (oldRep * fCod))
           (fDef' fDef'' : funType (newRep :: fDom) (newRep * fCod)),
    refineFun fDef'' fDef'
    -> refineFun_AbsR AbsR fDef fDef''
    -> refineFun_AbsR AbsR fDef fDef'.
Proof.
  intros.
  unfold refineFun_AbsR in *.
  induction fDom; simpl in *; intros.
  rewrite (H0 _ _ H1).
  exact (H _).
  apply (IHfDom (fun r => fDef r t)
                (fun r => fDef' r t)
                (fun r => fDef'' r t)); eauto.
Qed.

Lemma refineFun_To_refineFunAbsR
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef  : funType (oldRep :: fDom) (oldRep * fCod))
           (fDef' : funType (newRep :: fDom) (newRep * fCod)),
    refineFun (domcod_old_to_new AbsR fDef) fDef'
    <-> refineFun_AbsR AbsR fDef fDef'.
Proof.
  simpl.
  unfold refineFun_AbsR, domcod_old_to_new; split.
  - induction fDom; simpl; intros; eauto.
    + unfold refine; intros.
      eapply H in H1; computes_to_inv; subst; eauto.
    + intros;
        eapply (IHfDom (fun r => fDef r t) (fun r => fDef' r t)); eauto.
      intros; eapply H.
  - induction fDom; simpl; intros; eauto.
    + unfold refine; intros.
      computes_to_econstructor; intros.
      eapply H in H0; computes_to_inv; subst; eauto.
    + intros;
        eapply (IHfDom (fun r => fDef r t0) (fun r => fDef' r t0)); eauto.
Qed.

Lemma refineFunAbsR_domcod_old_to_new
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef : funType (oldRep :: fDom) (oldRep * fCod)),
    refineFun_AbsR AbsR fDef (domcod_old_to_new AbsR fDef).
Proof.
  intros.
  unfold refineFun_AbsR, domcod_old_to_new.
  under_fDom.
  { unfold refine; intros.
    computes_to_inv; destruct_ex; intuition eauto; subst.
  }
  eauto.
Qed.

Definition domcod_new_to_old'
           {newRep oldRep fDom fCod}
           (AbsR : oldRep -> newRep -> Prop)
           (fDef' : funType (newRep :: fDom) (newRep * fCod))
  : funType (oldRep :: fDom) (oldRep * fCod) :=
  cl_sup (fun a : funType (oldRep :: fDom) (oldRep * fCod) =>
            refineFun (domcod_old_to_new AbsR a) fDef').

Lemma cod_old_to_new_monotone
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef fDef' : funType fDom (oldRep * fCod)),
    refineFun fDef fDef'
    -> refineFun (cod_old_to_new AbsR fDef) (cod_old_to_new AbsR fDef').
Proof.
  induction fDom; simpl; intros.
  -setoid_rewrite H; reflexivity.
  - simpl; eauto.
Qed.

Lemma domcod_old_to_new_monotone
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef fDef'  : funType (oldRep :: fDom) (oldRep * fCod)),
    refineFun fDef fDef'
    -> refineFun (domcod_old_to_new AbsR fDef) (domcod_old_to_new AbsR fDef').
Proof.
  induction fDom; simpl; intros.
  - unfold domcod_old_to_new; simpl.
    setoid_rewrite H; reflexivity.
  - unfold domcod_old_to_new in *.
    simpl; eapply (IHfDom (fun r => fDef r t0) (fun r => fDef' r t0)); eauto.
    simpl; eauto.
Qed.

Lemma domcod_old_to_new_resp_inf_1'
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall P,
    refineFun (@domcod_old_to_new _ _ fDom fCod AbsR (cl_inf P))
              (cl_inf (fun f (* new Point *) =>
                         exists f',
                           P f'
                           /\ refineFun (@domcod_old_to_new _ _ fDom fCod AbsR f') f)).
Proof.
  intros; eapply (glb_refineFun_inf _ (fun f (* new Point *) =>
                         exists f',
                           P f'
                           /\ refineFun (@domcod_old_to_new _ _ fDom fCod AbsR f') f)).
  simpl; intros; destruct_ex; intuition subst.
  rewrite <- H1.
  eapply domcod_old_to_new_monotone.
  eapply (glb_refineFun_inf _ P); eauto.
Qed.

Lemma domcod_old_to_new_resp_inf_2'
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall P,
    P (refineFun_inf P)
    -> refineFun (cl_inf (fun f (* new Point *) =>
                         exists f',
                           P f'
                           /\ refineFun (@domcod_old_to_new _ _ fDom fCod AbsR f') f))
              (@domcod_old_to_new _ _ fDom fCod AbsR (cl_inf P))
.
Proof.
  intros; eapply (glb_refineFun_inf _ (fun f (* new Point *) =>
                         exists f',
                           P f'
                           /\ refineFun (@domcod_old_to_new _ _ fDom fCod AbsR f') f)).
  simpl; intros; destruct_ex; intuition subst.
  eexists (refineFun_inf P); split; intros; eauto.
  reflexivity.
Qed.

Lemma domcod_old_to_new_resp_sup_1'
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall P,
    refineFun (cl_sup (fun f (* new Point *) =>
                         exists f',
                           P f'
                           /\ refineFun f (@domcod_old_to_new _ _ fDom fCod AbsR f')))
              (@domcod_old_to_new _ _ fDom fCod AbsR (cl_sup P))
.
Proof.
  intros; eapply (lub_refineFun_sup _ (fun f (* new Point *) =>
                         exists f',
                           P f'
                           /\ refineFun f (@domcod_old_to_new _ _ fDom fCod AbsR f'))).
  simpl; intros; destruct_ex; intuition subst.
  rewrite H1.
  eapply domcod_old_to_new_monotone.
  eapply (lub_refineFun_sup _ P); eauto.
Qed.

Lemma domcod_old_to_new_resp_sup_2'
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall P,
    P (refineFun_sup P)
    -> refineFun
         (@domcod_old_to_new _ _ fDom fCod AbsR (cl_sup P))
         (cl_sup (fun f (* new Point *) =>
                    exists f',
                      P f'
                      /\ refineFun f (@domcod_old_to_new _ _ fDom fCod AbsR f'))).
Proof.
  intros.
  eapply (lub_refineFun_sup _ (fun f (* new Point *) =>
                                 exists f',
                                   P f'
                           /\ refineFun f (@domcod_old_to_new _ _ fDom fCod AbsR f'))).
  eexists (refineFun_sup P); intuition.
Qed.

Lemma refineFun_AbsR_unCurry
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef : funType fDom (oldRep * fCod))
           (fDef' : funType fDom (newRep * fCod)),
    refineFun_AbsR' _ _ AbsR fDef fDef'
    -> refineFun_AbsR' _ _ AbsR (unCurry _ fDef) (unCurry _ fDef').
  Proof.
    induction fDom; simpl.
    - intros; eauto.
    - intros.
      eapply IHfDom; eauto.
  Qed.

Lemma refineFun_AbsR_unCurry'
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef : funType fDom (oldRep * fCod))
           (fDef' : funType fDom (newRep * fCod)),
    refineFun_AbsR' _ _ AbsR (unCurry _ fDef) (unCurry _ fDef')
    -> refineFun_AbsR' _ _ AbsR fDef fDef'.
  Proof.
    induction fDom; simpl.
    - intros; eapply (H tt).
    - intros.
      eapply IHfDom; eauto.
      simpl; intros.
      eapply (H (t, t0)).
  Qed.

  (* Here's the main refinement lemma for switching the *)
  (* representation type of a fixed point! *)
Lemma refine_LeastFixedPoint_AbsR
      {oldRep newRep}
      (AbsR : oldRep -> newRep -> Prop)
      {fDom : list Type}
      {fCod : Type}
      (fDef : funType (oldRep :: fDom) (oldRep * fCod)
              -> funType (oldRep :: fDom) (oldRep * fCod))
      (fDef' : funType (newRep :: fDom) (newRep * fCod)
               -> funType (newRep :: fDom) (newRep * fCod))
  : respectful_hetero
      (funType (oldRep :: fDom) (oldRep * fCod))
      (funType (newRep :: fDom) (newRep * fCod))
      (fun _ => funType (oldRep :: fDom) (oldRep * fCod))
      (fun _ => funType (newRep :: fDom) (newRep * fCod))
      (fun f f' => @refineFun_AbsR _ _ AbsR fDom fCod f f')
      (fun rec rec' f f' =>
         @refineFun_AbsR _ _ AbsR fDom fCod f f')
      fDef fDef'
    -> forall (fDef_monotone : forall rec rec',
                  refineFun rec rec'
                  -> refineFun (fDef rec) (fDef rec'))
              (fDef'_monotone : forall rec rec',
                  refineFun rec rec'
                  -> refineFun (fDef' rec) (fDef' rec')),
      refineFun_AbsR AbsR (LeastFixedPoint fDef)
                     (LeastFixedPoint fDef').
Proof.
  unfold LeastFixedPoint, respectful_hetero; intros.
  unfold refineFun_AbsR; intros;
  simpl; eapply refineFun_AbsR'_trans.
  pose proof (proj1 (Is_GreatestFixedPoint
                       (O := @funDefOps (oldRep :: fDom) (oldRep * fCod))
                       _ (fDef_monotone))).
  simpl in *; rewrite H1; reflexivity.
  eapply refineFun_AbsR_trans'; eauto;
    [ | eapply H; eapply refineFunAbsR_domcod_old_to_new ].
  pose proof (proj2 (Is_GreatestFixedPoint
                       (O := @funDefOps (newRep :: fDom) (newRep * fCod))
                       _ (fDef'_monotone))).
  rewrite <- H1.
  eapply fDef'_monotone.
  eapply (GreatestFixedPoint_ind (O := @funDefOps (newRep :: fDom) (newRep * fCod))).
  simpl.
  eapply refineFun_To_refineFunAbsR.
  eapply refineFun_AbsR_trans; eauto.
  pose proof (proj1 (Is_GreatestFixedPoint
                       (O := @funDefOps (oldRep :: fDom) (oldRep * fCod))
                       _ (fDef_monotone))).
  eapply H2.
  eapply H.
  eapply refineFun_To_refineFunAbsR.
  reflexivity.
Qed.


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import Stc.StcSyntax.
From Velus Require Import Clocks.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

Module Type STCISLAST
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import CESyn : CESYNTAX      Op)
       (Import Syn   : STCSYNTAX Ids Op CESyn).

  Inductive Is_last_in_tc: ident -> trconstr -> Prop :=
    LastTcNext:
      forall x ck e,
        Is_last_in_tc x (TcNext x ck e).

  Definition Is_last_in (x: ident) (tcs: list trconstr) : Prop :=
    Exists (Is_last_in_tc x) tcs.

  Lemma not_Is_last_in_cons:
    forall x tc tcs,
      ~ Is_last_in x (tc :: tcs) <-> ~ Is_last_in_tc x tc /\ ~ Is_last_in x tcs.
  Proof.
    split; intros HH.
    - split; intro; apply HH; unfold Is_last_in; intuition.
    - destruct HH; inversion_clear 1; intuition.
  Qed.

  Lemma lasts_of_In:
    forall tcs x,
      Is_last_in x tcs <-> In x (lasts_of tcs).
  Proof.
    induction tcs as [|[]]; simpl.
    - now setoid_rewrite Exists_nil.
    - setoid_rewrite <-IHtcs; split; try right; auto.
      inversion_clear 1 as [?? Last|]; try inv Last; auto.
    - setoid_rewrite <-IHtcs; split.
      + inversion_clear 1 as [?? Last|]; try inv Last; auto.
      + intros [E|?].
        * subst; left; constructor.
        * right; auto.
    - setoid_rewrite <-IHtcs; split; try right; auto.
      inversion_clear 1 as [?? Last|]; try inv Last; auto.
    - setoid_rewrite <-IHtcs; split; try right; auto.
      inversion_clear 1 as [?? Last|]; try inv Last; auto.
  Qed.

  Definition is_last_in_tc_b (x: ident) (tc: trconstr) : bool :=
    match tc with
    | TcNext y ck e => ident_eqb x y
    | _ => false
    end.

  Definition is_last_in_b (x: ident) (tcs: list trconstr) : bool :=
    existsb (is_last_in_tc_b x) tcs.

  Fact Is_last_in_tc_reflect:
    forall x tc,
      Is_last_in_tc x tc <-> is_last_in_tc_b x tc = true.
  Proof.
    destruct tc; simpl; split;
      try discriminate; try now inversion 1.
    - inversion_clear 1; apply ident_eqb_refl.
    - rewrite ident_eqb_eq; intro; subst; constructor.
  Qed.

  Corollary Is_last_in_reflect:
    forall x tcs,
      Is_last_in x tcs <-> is_last_in_b x tcs = true.
  Proof.
    setoid_rewrite existsb_exists; setoid_rewrite Exists_exists.
    split; intros (?&?& Last); apply Is_last_in_tc_reflect in Last; eauto.
  Qed.

  Lemma Is_last_in_dec:
    forall x tcs,
      { Is_last_in x tcs } + { ~ Is_last_in x tcs }.
  Proof.
    intros;
      eapply Bool.reflect_dec, Bool.iff_reflect, Is_last_in_reflect.
  Qed.

End STCISLAST.

Module StcIsLastFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX      Op)
       (Syn   : STCSYNTAX Ids Op CESyn)
<: STCISLAST Ids Op CESyn Syn.
  Include STCISLAST Ids Op CESyn Syn.
End StcIsLastFun.


From iris.program_logic Require Import atomic.
From iris.heap_lang Require Export proofmode notation lang.
Require Export SegmentQueue.lib.concurrent_linked_list.infinite_array.array_spec.

Section impl.

Variable (array_interface: infiniteArrayInterface).

Definition findCellAndMoveForward: val :=
  λ: "ptr" "id" "startFrom",
  (rec: "loop" <> := let: "cell" := findCell array_interface "startFrom" "id" in
                    if: cutoffMoveForward array_interface "ptr" "cell"
                    then "cell"
                    else "loop" #()) #().

End impl.

Section proof.

Context `{!heapG Σ}.

Variable (array_interface: infiniteArrayInterface).
Variable (aspc: infiniteArraySpec Σ array_interface).

Theorem findCellAndMoveForward_spec N γ co p (v: val) (source_id id: nat):
  is_infinite_array _ _ aspc N γ co -∗
  is_infinite_array_cutoff_reading _ _ aspc N γ p source_id -∗
  <<< ∀ start_index, ▷ is_infinite_array_cutoff _ _ aspc N γ v start_index >>>
      findCellAndMoveForward array_interface v #id p @ ⊤ ∖ ↑N
  <<< ∃ p' id', is_infinite_array_cell_pointer _ _ aspc N γ p' id'
                ∗ ⌜(id ≤ id')%nat⌝
                ∗ (∀ i, (⌜max source_id id ≤ i < id'⌝)%nat
                        -∗ cell_is_cancelled _ _ aspc N γ i
                        ∗ (∃ ℓ, infinite_array_mapsto _ _ aspc N co γ i ℓ))
                ∗ ∃ i', ⌜start_index ≤ i' ≤ max id' start_index⌝ ∧
                  is_infinite_array_cutoff _ _ aspc N γ v i',
  RET p' >>>.
Proof.
  iIntros "#HArr #HReading" (Φ) "AU". wp_lam. wp_pures. iLöb as "IH".
  wp_bind (findCell _ _ _). iApply (findCell_spec with "[$]").
  iIntros (p' id') "!> (#HCellPointer & % & #HCancelled)". wp_pures.
  wp_bind (cutoffMoveForward _ _ _).
  awp_apply (cutoffMoveForward_spec with "HArr HCellPointer").
  iApply (aacc_aupd with "AU"); first done.
  iIntros (start_index) "HCutoff". iAaccIntro with "HCutoff".
  by iIntros "$ !> $ !> //".
  iIntros ([|]) "HResult".
  - iRight. iExists p', id'.
    iSplitL; last by iIntros "!> HΦ !>"; wp_pures.
    by iFrame "HCellPointer HCancelled HResult".
  - iLeft. iFrame "HResult". iIntros "!> AU !>". wp_pures.
    by iApply ("IH" with "AU").
Qed.

End proof.


Require Import ssreflect.

Require Import ZArith Array.PArray List String Floats.
Require Ascii.
Require Int63.
Import ListNotations.
Open Scope string_scope.

Require Import Malfunction.Malfunction.

(* type value = *)
(* | Block of int * value array *)
(* | Vec of vector_type * value array *)
(* | Func of (value -> value) *)
(* | Int of inttype * Z.t *)
(* | Float of float *)
(* | Thunk of value Lazy.t *)

Inductive value :=
| Block of int * array value
| Vec of vector_type * array value
| Func of Ident.t * @Ident.Map.t value * t
| value_Int of inttype * Z
| Float of float
| Thunk of value
| fail of string
.

Definition add (x : string) (v : value) (locals : string -> value)  :=
  fun y =>
    if String.eqb y x then v else locals y.

Definition option_def {A} (a : A) (x : option A) : A :=
  match x with
  | None => a
  | Some a => a
  end.

Fixpoint Array_of_List' {A} count (l : list A) (a : array A) :=
  match l with
  | [] => a
  | x :: l => Array_of_List' (S count) l (PArray.set a (Int63.of_Z (Z.of_nat count)) x)
  end.

Definition Array_of_list {A} (def : A) (l : list A) :=
  Array_of_List' 0 l (PArray.make (Int63.of_Z (Z.of_nat (List.length l))) def).

Definition Array_init {A} (size : int) f :=
  let g := fun x => (f (Int63.of_Z (Z.of_nat x))) in
  @Array_of_list A (g 0) (map g (seq 0 (Z.to_nat (Int63.to_Z size)))).

Definition inttype_eqb (t1 t2 : inttype) :=
  match t1, t2 with
  | Int, Int
  | Int32, Int32
  | Int64, Int64
  | Bigint, Bigint => true
  | _, _ => false
  end.

Definition vector_type_eqb (t1 t2 : vector_type) :=
  match t1, t2 with
  | Array, Array
  | Bytevec, Bytevec => true
  | _, _ => false
  end.

Definition fail_def {A} (a : A) (s : string) : A.
  exact a.
Qed.

Definition fail_float := fail_def infinity.
Definition fail_Z := fail_def Z.zero.

Definition bitwidth := fun t =>
  match t with
  | Int => 63
  | Int32 => 32
  | Int64 => 64
  | BigInt => fail_Z "no bitwidth for bigint"
  end%Z.

Definition truncate ty n :=
  value_Int (ty, match ty with
                 | Bigint => n
                 | ty =>
                     let width := bitwidth ty in
                     let range := Z.shiftl (Z.of_nat 1) width in
                     let masked := Z.land n (Z.sub range (Z.of_nat 1)) in
                     let min_int := Z.shiftr range 1 in
                     if Z.ltb masked min_int then masked else
                       Z.sub masked range
                 end).

Definition as_ty ty := fun ty2 =>
  match ty2 with
  | value_Int (ty', n) => if inttype_eqb ty ty' then n else fail_Z "integer type missmatch"
  | _ => fail_Z "expected integer"
  end.

Definition as_float x := match x with
  | Float f => f
                         | _ => fail_float "expected float64"
                         end.

Definition comparison_eqb x1 x2 :=
  match x1, x2 with
  | Datatypes.Lt, Datatypes.Lt | Datatypes.Gt, Datatypes.Gt | Datatypes.Eq, Datatypes.Eq => true
  | _, _ => false
  end.

#[bypass_check(guard)]
Fixpoint interpret
         (locals : @Ident.Map.t value)
         (env : @Ident.Map.t value)
         (x : t) {struct x} : value :=
  match x with
  | Mvar v => Ident.Map.find v locals
  | Mlambda (xs, e) =>
    let (x, e) := match xs with
     | [ ] => fail_def ("", Mvar "") "assert false"
     | [x] => (x, e)
     | x :: xs => (x, Mlambda (xs, e))
    end in
    Func (x, locals, e)
  | Mapply (f, vs) =>
      match interpret locals env f, vs with
      | Func (x, locs, e), v :: vs => interpret (Ident.Map.add x (interpret locals env v) locs) env (Mapply (e, vs))
      | _, _ => fail "not a function"
      end
  | Mnum (numconst_Int n) => value_Int (Int, Int63.to_Z n)
  (* | Mnum (`Int32 n) -> Int (`Int32, Z.of_int32 n) *)
  (* | Mnum (`Int64 n) -> Int (`Int64, Z.of_int64 n) *)
  | Mnum (numconst_Bigint n) => value_Int (Bigint, n)
  | Mnum (numconst_Float64 f) => Float f

  | Mstring s =>
     Vec (Bytevec,
           Array_init (Int63.of_Z (Z.of_nat (String.length s))) (fun i => value_Int (Int, (Z.of_nat (Ascii.nat_of_ascii (option_def Ascii.Space (String.get (Z.to_nat (Int63.to_Z i)) s)))))))

  | Mglobal _v => fail "globals unsupported"

  | Mswitch (scr, cases) =>
      let scr := interpret locals env scr in
      let fix find_match x := match x with
        | (cases, e) :: rest =>
            if List.existsb (fun case => match case, scr with
            | Tag n, Block (n', _) => Int63.eqb n n'
            | Deftag, Block _ => true
            | Intrange (min, max), value_Int (Int, n) => Z.leb (Int63.to_Z min) n && Z.leb n (Int63.to_Z max)
            | _, _ => false end) cases then
              interpret locals env e
            else
              find_match rest
        | [] => fail "no case matches" end in
      find_match cases

  | Mnumop1 (op, embed_inttype ty, e) =>
      let n := as_ty ty (interpret locals env e) in
      truncate ty (match op with Neg => Z.mul (-1) n | Not => Z.lnot n end)

  | Mnumop2 (op, embed_inttype ty, e1, e2) =>
      let e1 := interpret locals env e1 in
      let e2 := interpret locals env e2 in
      match op with
      | embed_binary_arith_op op =>
          let f := match op with
                   | Add => Z.add | Sub => Z.sub
                   | Mul => Z.mul | Div => Z.div | Mod => Z.rem
                   end in
          truncate ty (f (as_ty ty e1) (as_ty ty e2))
      | embed_binary_bitwise_op op =>
          let n := as_ty ty e1 in
          let c := as_ty Int e2 in
          (* TODO is this test necessary? *)
          truncate ty (match op with
          | And => Z.land (as_ty ty e1) (as_ty ty e2)
          | Or => Z.lor (as_ty ty e1) (as_ty ty e2)
          | Xor => Z.lxor (as_ty ty e1) (as_ty ty e2)
          | Lsl => Z.shiftl n c
          | Asr => Z.shiftr n c
          | Lsr =>
              let n := match ty with
                       | Bigint => n
                       | op =>
                           let w := bitwidth ty in
                           Z.land n (Z.sub (Z.shiftl (Z.of_nat 1) w) (Z.of_nat 1)) end in
              Z.shiftr n c end)
      | embed_binary_comparison op =>
          let cmp := Z.compare (as_ty ty e1) (as_ty ty e2) in
          let res := match op with
            | Lt => comparison_eqb cmp Datatypes.Lt
            | Gt => comparison_eqb cmp Datatypes.Gt
            | Lte => negb (comparison_eqb cmp Datatypes.Gt)
            | Gte => negb (comparison_eqb cmp Datatypes.Lt)
            | Eq => comparison_eqb cmp Datatypes.Eq
                     end in
          value_Int (Int, if res then 1%Z else 0%Z)
      end
  | Mnumop1 (Neg, Float64, e) =>
      Float (- as_float (interpret locals env e))
  | Mnumop1 (Not, Float64, _)
  | Mnumop2 (embed_binary_bitwise_op _, Float64, _, _) =>
      fail "invalid bitwise float operation"
  | Mnumop2 (embed_binary_arith_op op, Float64, e1, e2) =>
      let e1 := as_float (interpret locals env e1) in
      let e2 := as_float (interpret locals env e2) in
      Float (match op with
             | Add => e1 + e2
             | Sub => e1 - e2
             | Mul => e1 * e2
             | Div => e1 / e2
             | Mod => fail_float "mod on floats not supported" end)
  | Mnumop2 (embed_binary_comparison op, Float64, e1, e2) =>
      let e1 := as_float (interpret locals env e1) in
      let e2 := as_float (interpret locals env e2) in
      let res := match op with
             | Lt => PrimFloat.ltb e1 e2
             | Gt => PrimFloat.ltb e2 e2
             | Lte => PrimFloat.leb e1 e2
             | Gte => PrimFloat.leb e2 e1
             | Eq => PrimFloat.eqb e1 e2
                 end in
      value_Int (Int, if res then 1%Z else 0%Z)

  | Mconvert (embed_inttype src, embed_inttype dst, e) =>
      truncate dst (as_ty src (interpret locals env e))
  | Mconvert (embed_inttype src, Float64, e) =>
      Float (PrimFloat.of_uint63 (Int63.of_Z (as_ty src (interpret locals env e))))
  | Mconvert (Float64, Float64, e) =>
      Float (as_float (interpret locals env e))
  | Mvecnew (ty, len, def) =>
      match ty, interpret locals env len, interpret locals env def with
      | Array, value_Int (Int, len), v =>
          Vec (Array, PArray.make (Int63.of_Z len) v)
      | Bytevec, value_Int (Int, len), (value_Int (Int, k)) as v =>
          if Z.leb 0%Z k && Z.ltb k 256 then
            Vec (Bytevec, PArray.make (Int63.of_Z len) v)
          else
            fail "bad vector creation"
      | _, _, _ => fail "bad vector creation"
      end
  | Mvecget (ty, vec, idx) =>
      (match interpret locals env vec, interpret locals env idx with
       | Vec (ty', vals), value_Int (Int,i) =>
           if vector_type_eqb ty ty' then
             if Z.leb 0 i && Z.ltb i (Int63.to_Z (PArray.length vals)) then
               PArray.get vals (Int63.of_Z i)
             else
               fail "index out of bounds: %d"
           else
             fail "wrong vector type"
       | _, _ => fail "wrong vector type"
       end
      )
  | Mvecset (ty, vec, idx, e) => fail "not implemented"
      (* (match interpret locals env vec, *)
      (*        interpret locals env idx, *)
      (*        interpret locals env e with *)
      (*  | Vec (ty', vals), value_Int (Int, i), v => *)
      (*      if vector_type_eqb ty ty' then *)
      (*        let i := Int63.to_Z i in *)
      (*        if Int63.leb (Int63.of_int 0) i && Int63.leb i (PArray.length vals) then *)
      (*          match ty, v with *)
      (*          | Array, _ => tt *)
      (*          | Bytevec, Int (Int, i) *)
  (*      else fail "wrong vector type" *)
  | Mveclen (ty, vec) =>
      match interpret locals env vec with
      | Vec (ty', vals) =>
          if vector_type_eqb ty ty' then value_Int (Int, Int63.to_Z (PArray.length vals)) else fail "wrong vector type"
      | _ => fail "wrong vector type"
      end
  | Mblock (tag, vals) =>
      Block (tag, Array_of_list (fail "empty array") (List.map (interpret locals env) vals))
  | Mfield (idx, b) =>
      match interpret locals env b with
      | Block (_, vals) => PArray.get vals idx
      | _ => fail "not a block"
      end
  | Mlazy e => Thunk (interpret locals env e)
  | Mforce e =>
      match interpret locals env e with
      | Thunk v => v
      | _ => fail "not a lazy value"
      end
  | _ => fail "assert todo"
end.


Require Import Verse.
Require Import Verse.CryptoLib.blake2.
Require Import Verse.CryptoLib.blake2.c.portable.

Require Vector.
Import Vector.VectorNotations.

Module Config <: CONFIG.

  Definition Word   := Word64.
  Definition ROUNDS := 12.
  Definition IVVec  :=
    [
      Ox "6a09e667f3bcc908";
      Ox "bb67ae8584caa73b";
      Ox "3c6ef372fe94f82b";
      Ox "a54ff53a5f1d36f1";
      Ox "510e527fade682d1";
      Ox "9b05688c2b3e6c1f";
      Ox "1f83d9abfb41bd6b";
      Ox "5be0cd19137e2179"
    ].
  (** The rotation constants used by the G function *)
  Definition R0 := 32.
  Definition R1 := 24.
  Definition R2 := 16.
  Definition R3 := 63.

End Config.

Module Blake2b := Blake2 (Config).
Require Import Verse.Target.C.

Inductive name := verse_blake2b_c_portable_iter |verse_blake2b_c_portable_last.
Require Verse.CryptoLib.blake2.

Require Scope.

(*
Definition blake2bIter
  := Iterator verse_blake2b_c_portable_iter
              Blake2b.Block
              Blake2b.Compressor.
*)

Require Verse.Error.

Definition blake2bIter : CodeGen.Config.programLine + {Error.TranslationError}.
  Iterator verse_blake2b_c_portable_iter Blake2b.Block Blake2b.Compressor.
Defined.

Definition blake2bLast : CodeGen.Config.programLine + {Error.TranslationError}.
  Function verse_blake2b_c_portable_last
           Blake2b.LastBlockCompressor.
Defined.

Require Import Verse.Error.
Definition iterator   : Compile.programLine := recover (blake2bIter).
Definition lastchunk  : Compile.programLine := recover (blake2bLast).
Definition program := verseC [iterator; lastchunk].

Require Import Verse.FFI.Raaz.
Require Import Verse.FFI.Raaz.Target.C.

Definition raazFFI {Name}(name : Name)
  := mkProgram name [ iterator verse_blake2b_c_portable_iter
                                Blake2b.Block
                                Blake2b.Compressor;
                      function verse_blake2b_c_portable_last
                                Blake2b.LastBlockCompressor
                    ].
Arguments raazFFI [Name].

(*

Require Import Verse.Print.
Require Import Verse.Target.C.Pretty.
Goal to_print program.
  print.
Abort.

*)