Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Bedrock.Word
        Coq.ZArith.ZArith
        Coq.NArith.NArith
        Coq.Arith.Arith
        Coq.Numbers.Natural.Peano.NPeano
        Coq.Logic.Eqdep_dec
        Fiat.Common.BoundedLookup
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.BinLib.AlignedByteString.

Section AlignedEncodeM.

  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {S : Type}.

  Definition AlignedEncodeM
             (n : nat) :=
    ByteBuffer.t n (* Vector of bytes that is being written to *)
    -> nat          (* The current index *)
    -> S
    -> CacheFormat  (* The current environment *)
    -> Hopefully (ByteBuffer.t n * nat * CacheFormat) (* Error monad + value + updated index + updated cache *).

  Definition AppendAlignedEncodeM
             {n : nat}
             (a : AlignedEncodeM n)
             (b : AlignedEncodeM n)
    : AlignedEncodeM n :=
    fun v idx s c => (HBind a v idx s c  as a' With (b (fst (fst a')) (snd (fst a')) s (snd a'))).

  Definition ReturnAlignedEncodeM
             {numBytes : nat}
    : AlignedEncodeM numBytes :=
    fun v idx s c => Ok (v, idx, c).

  Definition AlignedEncodeMEquiv
             {n}
             (a1 a2 : AlignedEncodeM n) : Prop :=
    forall v idx s c, a1 v idx s c = a2 v idx s c.

  Lemma AlignedEncodeMEquiv_refl  {n}:
    forall (a : AlignedEncodeM n),
      AlignedEncodeMEquiv a a.
  Proof.
    unfold AlignedEncodeMEquiv; intros; reflexivity.
  Qed.

  Lemma AlignedEncodeMEquiv_sym  {n}:
    forall (a1 a2 : AlignedEncodeM n),
      AlignedEncodeMEquiv a1 a2 -> AlignedEncodeMEquiv a2 a1.
  Proof.
    unfold AlignedEncodeMEquiv; intros; congruence.
  Qed.

  Lemma AlignedEncodeMEquiv_trans  {n}:
    forall (a1 a2 a3 : AlignedEncodeM n),
      AlignedEncodeMEquiv a1 a2 ->
      AlignedEncodeMEquiv a2 a3 ->
      AlignedEncodeMEquiv a1 a3.
  Proof.
    unfold AlignedEncodeMEquiv; intros; congruence.
  Qed.

  Global Instance PreOrder_AlignedEncodeMEquiv  {n} :
    PreOrder (@AlignedEncodeMEquiv n) :=
    {| PreOrder_Reflexive := AlignedEncodeMEquiv_refl;
       PreOrder_Transitive := AlignedEncodeMEquiv_trans|}.

  Lemma AppendAlignedEncodeM_assoc {n}:
    forall (a : AlignedEncodeM n)
           (f : AlignedEncodeM n)
           (g : AlignedEncodeM n),
      AlignedEncodeMEquiv (AppendAlignedEncodeM (AppendAlignedEncodeM a f) g)
                          (AppendAlignedEncodeM a (AppendAlignedEncodeM f g)).
  Proof.
    unfold AppendAlignedEncodeM, AlignedEncodeMEquiv; simpl; intros.
    destruct (a v idx s c); simpl; eauto.
  Qed.

  Lemma ReturnAlignedEncodeM_LeftUnit {n}:
    forall (f : AlignedEncodeM n),
      AlignedEncodeMEquiv (AppendAlignedEncodeM (@ReturnAlignedEncodeM _) f)
                          f.
  Proof.
    intros; reflexivity.
  Qed.

  Lemma ReturnAlignedEncodeM_RightUnit {n}:
    forall (f : AlignedEncodeM n),
      AlignedEncodeMEquiv (AppendAlignedEncodeM f ReturnAlignedEncodeM) f.
  Proof.
    unfold ReturnAlignedEncodeM, AppendAlignedEncodeM, AlignedEncodeMEquiv; simpl; intros.
    destruct (f v idx s c) as [ [ [? ?] ?] | ] ; simpl; reflexivity.
  Qed.
  Definition ThrowAlignedEncodeM
             {n : nat}
    : AlignedEncodeM n:=
    fun _ _ _ _ => OtherErrorInfo "Alignment error (ThrowAligned)".

  Fixpoint set_nth'
           {n : nat}
           (v : ByteBuffer.t n)
           (m : nat)
           (a : char)
    : ByteBuffer.t n :=
    match m, v with
    | 0,  Vector.cons _ _ v' => Vector.cons _ a _ v'
    | Datatypes.S m', Vector.cons a' _ v' => Vector.cons _ a' _ (set_nth' v' m' a)
    | _, _ => @Vector.nil _
    end.

  (* Equivalence Criteria:
     A bit-aligned encoder and byte-aligned encoder are equivalent when
\backsimeq     - the byte aligned encoder fails when the bit aligned encoder would write past
       the end of the bytestring
     - encodes the same bit sequence values as the bit-aligned encoder (and who can
       say about the rest of the .
   *)

  Definition EncodeMEquivAlignedEncodeM
             (f : EncodeM S ByteString)
             (f' : forall numBytes, AlignedEncodeM numBytes)
    := forall env s idx,
      (forall t env',
          f s env = Ok (t, env')
          -> padding t = 0 ->
          forall (v1 : Vector.t char idx) v m v2,
          exists v',
            f' _ (Vector.append v1 (Vector.append (n := numBytes t) (p := m)
                                                  v v2)) idx s env = Ok (v', idx + numBytes t, env') /\
            ByteString_enqueue_ByteString (build_aligned_ByteString v1)
                                          (ByteString_enqueue_ByteString t (build_aligned_ByteString v2))
            = build_aligned_ByteString v')%nat
      /\ (forall t env' numBytes' v,
             f s env = Ok (t, env')
             -> 8 + 8 * numBytes' <= length_ByteString t + (8 * idx)
          -> is_error (f' numBytes' v idx s env))%nat
      /\ (forall t env' numBytes' v,
             f s env = Ok (t, env')
             -> padding t <> 0 -> is_error (f' numBytes' v idx s env))%nat
      /\ (forall numBytes' v, is_error (f s env) -> is_error(f' numBytes' v idx s env)).

  Lemma EncodeMEquivAlignedEncodeM_trans :
    forall bit_decoder1 byte_decoder1 bit_decoder2 byte_decoder2,
      EncodeMEquivAlignedEncodeM bit_decoder1 byte_decoder1
      -> (forall s env, bit_decoder1 s env  = bit_decoder2 s env)
      -> (forall n, AlignedEncodeMEquiv (byte_decoder1 n) (byte_decoder2 n))
      -> EncodeMEquivAlignedEncodeM bit_decoder2 byte_decoder2.
  Proof.
    unfold EncodeMEquivAlignedEncodeM; intros; intuition.
    - revert v1 v v2 H2; rewrite <- ?H0, <- ?H1; intros.
      destruct (proj1 (H _ _ _) _ _ H2 H3 v1 v m v2); intuition.
      eexists; intuition eauto.
      rewrite <- H1; eauto.
    - rewrite <- ?H0, <- ?H1; intros.
      eapply (proj1 (proj2 (H _ _ _))); eauto; rewrite H0; eauto.
    - rewrite <- ?H0, <- ?H1; intros.
      eapply (proj1 (proj2 (proj2 (H _ _ _)))); rewrite ?H0; eauto.
    - rewrite <- ?H0 in H2.
      rewrite <- H1; eapply H; eauto.
  Qed.

  Local Arguments mult : simpl never.

  Definition AlignedEncode_Nil
             numBytes
    : AlignedEncodeM numBytes :=
    (fun v idx s env => (if idx <? Datatypes.S numBytes
                         then
                           @ReturnAlignedEncodeM _ v idx s env
                         else
                           Error (LabelError "Alignment error, reading nill (AlignedEncode_Nil)" EndOfBuffer))).

  Lemma Return_EncodeMEquivAlignedEncodeM
    : EncodeMEquivAlignedEncodeM
        (fun (s : S) (env : CacheFormat) => Ok (mempty, env))
        AlignedEncode_Nil.
  Proof.
    unfold EncodeMEquivAlignedEncodeM, AlignedEncode_Nil, ReturnAlignedEncodeM;
      intros; injections; simpl in *; intuition.
    - injections; simpl.
      assert (idx < Datatypes.S (idx + m))%nat as H' by lia;
        rewrite <- ltb_lt in H'; rewrite H'.
      revert v.
      eapply Vector.case0; simpl.
      rewrite (plus_comm idx 0); simpl; eexists _; intuition.
      pose proof (mempty_left (build_aligned_ByteString v2)) as H'';
        simpl in H'';
      rewrite H'', <- build_aligned_ByteString_append; reflexivity.
    - injections; simpl in *.
      destruct (idx <? (Datatypes.S numBytes')) eqn: ?.
      rewrite ltb_lt in Heqb.
      lia.
      constructor.
    - injections; simpl in *; lia.
  Qed.

  Local Arguments plus : simpl never.

  Lemma Append_EncodeMEquivAlignedEncodeM
        (encode1 encode2 : EncodeM S ByteString)
        (encode1_aligned encode2_aligned : forall {numBytes}, AlignedEncodeM numBytes)
        (encode1_OK : forall s env t env',
            encode1 s env = Ok (t, env') -> padding t = 0)
    : EncodeMEquivAlignedEncodeM encode1 (@encode1_aligned)
      -> EncodeMEquivAlignedEncodeM encode2 (@encode2_aligned)
      -> EncodeMEquivAlignedEncodeM
           (sequence_Encode encode1 encode2)
           (fun numBytes => AppendAlignedEncodeM encode1_aligned encode2_aligned).
  Proof.
    (*
    unfold EncodeMEquivAlignedEncodeM; intros; specialize (encode1_OK s env); repeat split; intros.
    - destruct (H env s idx) as [ H' [? ?] ].
      revert H1 v H' H2 H3 H4;
        unfold sequence_Encode;
        destruct (encode1 s env) as [ [t1 env''] | ] eqn: ? ;
        [ | intros; try discriminate];
        simpl; destruct (encode2 s env'') as [ [t2 env'''] | ] eqn: ? ; simpl in *;
          try (intros; discriminate);
          intro; injection H1; intros ? ?; subst;
            simpl; rewrite numBytes_ByteString_enqueue_ByteString;
              intros; eauto.
      destruct (H0 env'' s (idx + (numBytes t1))) as [H0' [? [? ?] ] ].
      specialize (H0' _ _ Heqh0).
      erewrite <- padding_ByteString_enqueue_aligned_ByteString in H0'.
      destruct (H' _ _ (eq_refl _) (encode1_OK _ _ (eq_refl _)) v1 (fst (Vector_split _ _ v)) _
                   (Vector.append (snd (Vector_split _ _ v)) v2)) as [? [? ?] ].
      assert (idx + (numBytes t1 + (numBytes t2 + m)) =
              (idx + numBytes t1) + (numBytes t2 + m)) by lia; simpl in *.
      destruct (H0' H2 (fst (Vector_split _ _ (eq_rect _ (Vector.t char) x _ H10)))
                    (fst (Vector_split _ _ (snd (Vector_split _ _ (eq_rect _ (Vector.t char) x _ H10)))))
                    _ (snd (Vector_split _ _ (snd (Vector_split _ _ (eq_rect _ (Vector.t char) x _ H10)))))
               ).
      assert (idx + numBytes t1 + (numBytes t2 + m) =
              idx + (numBytes t1 + numBytes t2 + m)) as H11' by lia.
      assert (idx + (numBytes t1 + (numBytes t2 + m)) =
              (idx + (numBytes t1 + numBytes t2 + m))) by lia; simpl in *.
      unfold AppendAlignedEncodeM.
      replace (encode1_aligned (idx + ((numBytes t1 + numBytes t2) + m))
                               (Vector.append v1 (Vector.append v v2)) idx s env)
        with (Some (eq_rect _ (Vector.t char) x _ H12, idx + numBytes t1, env''));
        simpl.
      + revert H12; rewrite <- H11'; intros.
        rewrite (plus_assoc idx (numBytes t1) (numBytes t2)).
        eexists _; intuition.
        * etransitivity; [ | apply H4].
          f_equal.
          rewrite <- !Vector_split_append.
          f_equal; eapply UIP_dec; intros; decide equality.
        * rewrite <- H15.
          rewrite ByteString_enqueue_ByteString_assoc.
          rewrite ByteString_enqueue_ByteString_assoc.
          rewrite <- ByteString_enqueue_ByteString_assoc.
          symmetry in H9; destruct (build_aligned_ByteString_split' _ _ _ H9)
            as [? H'']; symmetry in H''; destruct (build_aligned_ByteString_split _ _ _ H'').
          revert H16 H9; clear.
          intro.
          revert H10 x v.
          assert (idx + (numBytes t1 + (numBytes t2 + m)) - idx - (numBytes t2 + m) = numBytes t1)
            as H''' by lia; revert x2 H16; rewrite H'''; clear H'''.
          generalize (numBytes t1); intros; subst.
          rewrite <- !build_aligned_ByteString_append in H9;
            apply build_aligned_ByteString_inj in H9; subst.
          rewrite <- !build_aligned_ByteString_append; repeat f_equal.
          erewrite Vector_append_assoc.
          rewrite <- Equality.transport_pp.
          erewrite (UIP_dec _ _ (eq_refl _)); simpl.
          rewrite <- Vector_append_split_fst; reflexivity.
          erewrite Vector_append_assoc.
          rewrite <- Equality.transport_pp.
          erewrite (UIP_dec _ _ (eq_refl _)); simpl.
          rewrite <- !Vector_append_split_snd; reflexivity.
      + generalize x H8 H12; clear; intros.
         replace (Some
                    (eq_rect (idx + (numBytes t1 + (numBytes t2 + m)))
                             (Vector.t char) x (idx + (numBytes t1 + numBytes t2 + m)) H12,
                     idx + numBytes t1, env'')) with
             (eq_rect _ (fun x => option ((Vector.t char x) * nat * CacheFormat))%type (Some (x, idx + numBytes t1, env'')) _ H12).
         rewrite <- H8.
         assert (idx + (numBytes t1 + numBytes t2 + m) =
                 idx + (numBytes t1 + (numBytes t2 + m))) by lia.
         replace (Vector.append v1 (Vector.append (fst (Vector_split (numBytes t1) (numBytes t2) v))
                                                  (Vector.append (snd (Vector_split (numBytes t1) (numBytes t2) v)) v2)))
           with (eq_rect _ (Vector.t char) (Vector.append v1 (Vector.append v v2)) _ H).
         assert (forall n m (H' : n = m) (v : Vector.t char n),
                    encode1_aligned m (eq_rect n (Vector.t char) v _ H') idx s env =
                    eq_rect n (fun x => option ((Vector.t char x) * nat * CacheFormat))%type
                            (encode1_aligned _ v idx s env) _ H') as H'
             by (intros ? ? H'; rewrite H'; reflexivity).
         rewrite H', <- Equality.transport_pp.
         erewrite (UIP_dec _ _ (eq_refl _)); reflexivity.
         assert (numBytes t1 + numBytes t2 + m = numBytes t1 + (numBytes t2 + m)) by lia.
         replace (Vector.append (fst (Vector_split (numBytes t1) (numBytes t2) v))
                                (Vector.append (snd (Vector_split (numBytes t1) (numBytes t2) v)) v2))
           with (eq_rect _ (Vector.t char) (Vector.append v v2) _ H0)
           by (erewrite Vector_append_assoc, <- Vector_split_append; reflexivity).
         erewrite Vector_append_assoc', Vector_append_assoc, <- Equality.transport_pp.
         reflexivity.
         destruct H12; reflexivity.
      + eapply encode1_OK; eauto.
    - specialize (H env s idx);
        unfold sequence_Encode in *;
        destruct (encode1 s env) as [ [t1 env''] | ] eqn: ? ;
        simpl in *; [ | intros; try discriminate];
        simpl; destruct (encode2 s env'') as [ [t2 env'''] | ] eqn: ? ; simpl in *;
          try (intros; discriminate).
      pose proof (proj1 H _ _ (eq_refl _) (encode1_OK _ _ (eq_refl _))).
      injections.
      rewrite length_ByteString_enqueue_ByteString in H2.
      unfold AppendAlignedEncodeM; destruct (encode1_aligned numBytes' v idx s env) eqn: ? ;
          simpl; eauto.
        destruct (le_lt_dec (8 + 8 * numBytes')
                            (length_ByteString t1 + 8 * idx)).
        { eauto; simpl in l; eapply (proj1 (proj2 H)) in l; eauto; rewrite Heqo in l. discriminate. }
        rewrite length_ByteString_no_padding in l by eauto.
        pose proof (proj1 (proj2 (H0 env'' s (snd (fst p))))) as H'.
        assert (numBytes t1 + idx < Datatypes.S numBytes')%nat by lia; clear l.
        assert (idx + numBytes t1 <= numBytes')%nat by lia.
        destruct (Vector_split_lt _ _ H4 v) as [? [? [? [? ?] ] ] ].
        pose proof (proj1 (proj2 (H))) as H'' .
        destruct (H3 (fst (Vector_split _ _ x0)) (snd (Vector_split _ _ x0)) _ x1) as [v' [? ?] ].
        erewrite <- H'; f_equal; clear H'.
      + revert p Heqo H6.
        rewrite H5.
        rewrite <- x2; simpl; clear.
        rewrite Vector_append_assoc with (H := sym_eq (plus_assoc idx (numBytes t1) x)), <- Vector_split_append.
        generalize v' (eq_sym (plus_assoc idx (numBytes t1) x)).
        rewrite (plus_assoc idx (numBytes t1) x).
        intros. erewrite (UIP_dec _ _ (eq_refl _)) in H6; simpl in H6.
        rewrite Heqo in H6; destruct p as [ [? ?] ?]; simpl in *; congruence.
      + rewrite Heqh0; simpl; eauto.
      + replace (8 * snd (fst p)) with (length_ByteString t1 + 8 * idx); try lia.
        rewrite length_ByteString_no_padding by eauto.
        revert p Heqo H6.
        rewrite H5.
        rewrite <- x2; simpl; clear.
        rewrite Vector_append_assoc with (H := sym_eq (plus_assoc idx (numBytes t1) x)), <- Vector_split_append.
        generalize v' (eq_sym (plus_assoc idx (numBytes t1) x)).
        rewrite (plus_assoc idx (numBytes t1) x).
        intros. erewrite (UIP_dec _ _ (eq_refl _)) in H6; simpl in H6.
        rewrite Heqo in H6; destruct p as [ [? ?] ?]; simpl in *; injections.
        lia.
      - specialize (H env s idx);
        unfold sequence_Encode in *;
        destruct (encode1 s env) as [ [t1 env''] | ] eqn: ? ;
        simpl in *; [ | intros; try discriminate];
        simpl; destruct (encode2 s env'') as [ [t2 env'''] | ] eqn: ? ; simpl in *;
          try (intros; discriminate); injections.
        pose proof (proj1 H _ _ (eq_refl _) (encode1_OK _ _ (eq_refl _))).
        rewrite padding_ByteString_enqueue_aligned_ByteString in H2 by eauto.
        unfold AppendAlignedEncodeM; destruct (encode1_aligned numBytes' v idx s env) eqn: ? ;
          simpl; eauto.
        destruct (le_lt_dec (8 + 8 * numBytes')
                            (length_ByteString t1 + 8 * idx)).
        { eauto; simpl in l; eapply (proj1 (proj2 H)) in l; eauto; rewrite l in Heqo; discriminate. }
        rewrite length_ByteString_no_padding in l by eauto.
        pose proof (proj1 (proj2 (proj2 (H0 env'' s (snd (fst p)))))) as H'.
        assert (numBytes t1 + idx < Datatypes.S numBytes')%nat by lia; clear l.
        assert (idx + numBytes t1 <= numBytes')%nat by lia.
        destruct (Vector_split_lt _ _ H4 v) as [? [? [? [? ?] ] ] ].
        pose proof (proj2 (proj2 (H))) as H'' .
        destruct (H1 (fst (Vector_split _ _ x0)) (snd (Vector_split _ _ x0)) _ x1) as [v' [? ?] ].
        erewrite <- H'; f_equal; clear H'; eauto.
        * revert p Heqo H6.
          rewrite H5.
          rewrite <- x2; simpl; clear.
          rewrite Vector_append_assoc with (H := sym_eq (plus_assoc idx (numBytes t1) x)), <- Vector_split_append.
          generalize v' (eq_sym (plus_assoc idx (numBytes t1) x)).
          rewrite (plus_assoc idx (numBytes t1) x).
          intros. erewrite (UIP_dec _ _ (eq_refl _)) in H6; simpl in H6.
          rewrite Heqo in H6; destruct p as [ [? ?] ?]; simpl in *; try congruence.
      - specialize (H env s idx);
        unfold sequence_Encode in *;
        destruct (encode1 s env) as [ [t1 env''] | ] eqn: ? ; simpl in *.
        + destruct (encode2 s env'') as [ [t2 env'''] | ] eqn: ? ; simpl in *;
            try inversion H1.
          unfold AppendAlignedEncodeM.
          destruct (Nat.le_decidable (8 + 8 * numBytes') (length_ByteString t1 + 8 * idx)).
          erewrite (proj1 (proj2 H)); eauto.
          destruct (PeanoNat.Nat.eq_dec (padding t1) 0).
          unfold length_ByteString in H2; rewrite e in H2; simpl in H2.
          assert (exists m, numBytes' = idx + (numBytes t1 + m)).
          exists (numBytes' - (idx + numBytes t1)).
          lia.
          destruct H3.
          pose proof (proj1 H _ _ (eq_refl _) (encode1_OK _ _ (eq_refl _))) as H'.
          destruct (H' (fst (Vector_split _ _ (eq_rect _ _ v _ H3)))
                         (fst (Vector_split _ _ (snd (Vector_split _ _ (eq_rect _ _ v _ H3)))))
                         _
                         (snd (Vector_split _ _ (snd (Vector_split _ _ (eq_rect _ _ v _ H3))))))
            as [v' [? ?] ].
          replace (encode1_aligned _ v idx s env)
            with (Some (eq_rect _ (Vector.t char) v' _ (sym_eq H3), idx + numBytes t1, env'')).
          * simpl; eapply H0. rewrite Heqh0; f_equal; auto.
          * generalize v' H3 H4; clear; intros.
            revert v v' H4; rewrite H3; intros; simpl; f_equal.
            unfold ByteBuffer.t in *.
            rewrite <- H4; f_equal.
            rewrite <- !Vector_split_append; reflexivity.
          * erewrite (proj1 (proj2 (proj2 H))); eauto.
        + unfold AppendAlignedEncodeM; rewrite (proj2 (proj2 (proj2 H))); simpl; eauto.
          Unshelve.
          all: eauto using Nat.eq_dec; lia.
  Qed.
     *)
  Admitted.

  Definition CorrectAlignedEncoder
             (format : FormatM S ByteString)
             (encoder : forall sz, AlignedEncodeM sz)
    := {encoder' : EncodeM S ByteString &
                   (forall s env,
                       (forall t env', encoder' s env = Ok (t, env')
                                       -> refine (format s env) (ret (t, env')))
                       /\ (is_error (encoder' s env) ->
                           forall benv', ~ computes_to (format s env) benv'))
                   /\ (forall s env t env',
                          encoder' s env = Ok (t, env')
                       -> padding t = 0)
                   /\ EncodeMEquivAlignedEncodeM encoder' encoder}.

  Lemma CorrectAlignedEncoderForDoneC
    : CorrectAlignedEncoder (fun s e => Return (ByteString_id, e)) AlignedEncode_Nil.
  Proof.
    unfold CorrectAlignedEncoder; intros.
    eexists (fun _ env => Ok (ByteString_id, env)); split; [ | split]; intros.
    - split; intros.
      + congruence.
      + inversion H.
    - injections; reflexivity.
    - eapply Return_EncodeMEquivAlignedEncodeM.
  Defined.

  (* Lemma CorrectAlignedEncoderForDoneC A
        (format_A : FormatM A ByteString)
        (encode_A : A -> forall sz, AlignedEncodeM sz)
        (encoder_A_OK : CorrectAlignedEncoder format_A encode_A)
    : CorrectAlignedEncoder
        (fun a => format_A a DoneC)
        encode_A.
  Proof.
    unfold CorrectAlignedEncoder; intros.
    destruct encoder_A_OK as [encoder [? [? ?] ] ].
    exists encoder; split; intros; eauto.
    intros; rewrite <- H.
    unfold compose, Bind2.
    setoid_rewrite Monad.refineEquiv_bind_unit; simpl.
    pose proof mempty_right as H'; simpl in H'; setoid_rewrite H'.
    intros v Comp_v; computes_to_inv; subst.
    destruct v; simpl in *; auto.
    computes_to_econstructor; eauto.
  Qed. *)

  Lemma CorrectAlignedEncoderForThenC
        (format_A format_B : FormatM S ByteString)
        (encode_A : forall sz, AlignedEncodeM sz)
        (encode_B : forall sz, AlignedEncodeM sz)
        (encoder_A_OK : CorrectAlignedEncoder format_A encode_A)
        (encoder_B_OK : CorrectAlignedEncoder format_B encode_B)
        (encoder_A_OK' :
           forall (s : S) (env : CacheFormat) (tenv' tenv'' : ByteString * CacheFormat),
            format_B s env ∋ tenv' ->
            format_A s (snd tenv') ∋ tenv'' ->
            exists tenv3 tenv4 : _ * CacheFormat,
              projT1 encoder_B_OK s env = Ok tenv3
              /\ format_A s (snd tenv3) ∋ tenv4)
    : CorrectAlignedEncoder
        (format_B ++ format_A)
        (fun sz => AppendAlignedEncodeM (encode_B sz) (encode_A sz)).
  Proof.
    unfold CorrectAlignedEncoder; intros.
    destruct encoder_A_OK as [encoder_A ?], encoder_B_OK as [encoder_B ?]; intuition.
    destruct a0 as [? [? ?] ].
    eexists (sequence_Encode encoder_B encoder_A); split; [ | split];
      intros; simpl in *.
    3: eapply Append_EncodeMEquivAlignedEncodeM.
    4: apply e0.
    4: apply H2.
    3: apply e.
    pose proof (fun H a => CorrectEncoder_sequence format_B format_A encoder_B encoder_A H encoder_A_OK' a).
    destruct H0.
    - unfold CorrectEncoder; split; intros.
      specialize (proj1 (a _ _) _ _ H0); intro.
      unfold refine in H3; eauto.
      specialize (proj2 (a _ _) H0); intro.
      intro.
      eapply H3; eauto.
    - unfold CorrectEncoder; split; intros.
      specialize (proj1 (H _ _) _ _ H0); intro.
      unfold refine in H3; eauto.
      specialize (proj2 (H _ _) H0); intro.
      intro.
      eapply H3; eauto.
    - split; intros.
      + apply H0 in H4.
        intros ? ?; computes_to_inv; subst.
        eauto.
      + destruct benv'.
        eapply H3 in H4.
        eauto.
    - unfold sequence_Format, sequence_Encode, Bind2 in *.
      apply_in_hyp DecodeBindOpt_inv; destruct_ex; split_and.
      symmetry in H4.
      apply_in_hyp DecodeBindOpt_inv; destruct_ex; split_and.
      injections.
      rewrite padding_ByteString_enqueue_aligned_ByteString; eauto.
  Defined.

End AlignedEncodeM.

Lemma refine_CorrectAlignedEncoder
      {S : Type}
      {cache : Cache}
  : forall format format' encode,
    (forall (s : S) (env : CacheFormat),
        refine (format s env) (format' s env)
        /\ ((forall v, ~ computes_to (format' s env) v)
            -> (forall v, ~ computes_to (format s env) v)))
    -> (CorrectAlignedEncoder format' encode)
    -> (CorrectAlignedEncoder format encode).
Proof.
  unfold CorrectAlignedEncoder; intros.
  destruct X as [? [? ?] ]; eexists; intuition eauto.
  rewrite (proj1 (H _ _)); eauto.
  eapply H0; eauto.
  eapply H; eauto.
  intros.
  eapply H0 in H1; eauto.
Defined.

Lemma EncodeMEquivAlignedEncodeM_morphism
      {S : Type}
      {cache : Cache}
  : forall x (encode encode': forall sz : nat, AlignedEncodeM sz),
    (forall sz v idx w c, encode' sz v idx w c ~= encode sz v idx w c) ->
    EncodeMEquivAlignedEncodeM (S := S) x encode ->
    EncodeMEquivAlignedEncodeM (S := S) x encode'.
Proof.
  unfold EncodeMEquivAlignedEncodeM; intros * Heq Hequiv.
  intros a b c. specialize (Hequiv a b c).
  split_and. constructor; [|constructor].
  - intros d e f g h i j k.
    specialize (H d e f g h i j k).
    destruct H as [x' [? ?]].
    exists x'.
    eapply Ok_eq in H as HH; try (symmetry; eapply Heq).
    rewrite <- HH. split; eauto.
  - intros **.
    rewrite Heq. eauto.
  - split; eauto; intros;
      rewrite Heq; eauto.
Qed.

Lemma CorrectAlignedEncoder_morphism
      {S : Type}
      {cache : Cache}
  : forall format format' (encode encode': forall sz : nat, AlignedEncodeM sz),
    (EquivFormat format' format) ->
    (forall sz v idx w c, encode' sz v idx w c ~= encode sz v idx w c) ->
    CorrectAlignedEncoder (S := S) format encode ->
    CorrectAlignedEncoder (S := S) format' encode'.
Proof.
  unfold CorrectAlignedEncoder; intros.
  destruct X as [? [? ?] ]; eexists; intuition eauto.
  eapply H1 in H2; rewrite <- H2; eapply H.
  eapply H1 in H2; eauto.
  eapply H; eauto.
  eauto using EncodeMEquivAlignedEncodeM_morphism.
Defined.

Lemma CorrectAlignedEncoderThenCAssoc
      {S : Type}
      {cache : Cache}
      (format_A format_B format_C : FormatM S ByteString)
      (encode : forall sz, AlignedEncodeM sz)
  : CorrectAlignedEncoder
      ((format_A ++ format_B) ++ format_C)
      encode
    -> CorrectAlignedEncoder
         (format_A ++ format_B ++ format_C)
         encode.
Proof.
  intros; eapply refine_CorrectAlignedEncoder; eauto.
  unfold sequence_Format, compose; intros.
  unfold Bind2.
  split.
  - repeat setoid_rewrite Monad.refineEquiv_bind_bind.
    setoid_rewrite Monad.refineEquiv_bind_unit; simpl.
    f_equiv; intro.
    simpl; f_equiv; intro.
    simpl; f_equiv; intro.
    rewrite ByteString_enqueue_ByteString_assoc; reflexivity.
  - intros.
    intro; eapply (H v).
    computes_to_inv; repeat computes_to_econstructor; eauto.
    simpl; subst.
    rewrite <- ByteString_enqueue_ByteString_assoc; reflexivity.
Defined.

Corollary Guarded_CorrectAlignedEncoderThenCAssoc
          {S : Type}
          {cache : Cache}
          (format_A format_B format_C : FormatM S ByteString)
          (encode : forall sz, AlignedEncodeM sz)
  : (forall env s bs env', computes_to (format_A s env) (bs, env') ->
                       length_ByteString bs < 8)%nat
    -> CorrectAlignedEncoder
         ((format_A ++ format_B) ++ format_C)
         encode
    -> CorrectAlignedEncoder
         (format_A ++ format_B ++ format_C)
         encode.
Proof.
  intros; eapply CorrectAlignedEncoderThenCAssoc; eauto.
Defined.

Lemma CorrectAlignedEncoderThenCAssoc'
      {S : Type}
      {cache : Cache}
      (format_A format_B format_C : FormatM S ByteString)
      (encode : forall sz, AlignedEncodeM sz)
  : CorrectAlignedEncoder
      (format_A ++ format_B ++ format_C)
      encode
    -> CorrectAlignedEncoder
         ((format_A ++ format_B) ++ format_C)
         encode.
Proof.
  intros; eapply refine_CorrectAlignedEncoder; eauto.
  unfold sequence_Format, compose; intros.
  unfold Bind2.
  split.
  - repeat setoid_rewrite Monad.refineEquiv_bind_bind.
    setoid_rewrite Monad.refineEquiv_bind_unit; simpl; f_equiv; intro.
    simpl; f_equiv; intro.
    simpl; f_equiv; intro.
    rewrite ByteString_enqueue_ByteString_assoc; reflexivity.
  - intros ? ? ?; eapply (H v).
    computes_to_inv; subst; repeat computes_to_econstructor; eauto.
    simpl; subst.
    rewrite  ByteString_enqueue_ByteString_assoc; reflexivity.
Defined.

Definition Format_Source_Intersection
           {A B}
           {cache}
           (format : @FormatM A B cache)
           (predicate : A -> Prop)
  : @FormatM A B cache
  := fun a env benv =>
       predicate a /\
       format a env benv.

Definition CorrectAlignedEncoderFor {S} {cache}
           (format : @FormatM S ByteString cache)
  := {encode : _ & CorrectAlignedEncoder format encode}.

Definition SetCurrentByte (* Sets a single byte at the current index and increments the current index. *)
           {cache : Cache}
           {cacheAddNat : CacheAdd cache nat}
           {n : nat}
  : @AlignedEncodeM cache char n :=
  fun v idx s ce => if (idx <? n)
                    then Ok (set_nth' v idx s, Datatypes.S idx, addE ce 8)
                    else Error (InfoError "Error setting current byte" EndOfBuffer).

Definition Projection_AlignedEncodeM
           {S' S'' : Type}
           {cache : Cache}
           (encode : forall sz, AlignedEncodeM (S := S'') sz)
           (f : S' -> S'')
           (n : nat)
  : AlignedEncodeM (S := S') n :=
  fun v idx s' env =>
    encode n v idx (f s') env.

Lemma CorrectAlignedEncoderProjection
      {S S' : Type}
      {cache : Cache}
      (format_S : FormatM S' ByteString)
      (f : S -> S')
      (encode : forall sz, AlignedEncodeM sz)
  : CorrectAlignedEncoder format_S encode
    -> CorrectAlignedEncoder
         (Projection_Format format_S f)
         (Projection_AlignedEncodeM encode f).
Proof.
  intros H; destruct H as [? [? [? ?] ] ].
  eexists (Basics.compose x f); intuition.
  - intros; intros ? ?.
    eapply H in H3.
    unfold Projection_Format, Compose_Format; apply unfold_computes; eexists; split; eauto.
    apply H2.
  - unfold Projection_Format, Compose_Format in H3.
    rewrite @unfold_computes in H3; destruct_ex; intuition.
    eapply H in H2; eauto.
    subst; eauto.
  - eapply H0.
    unfold Basics.compose in H2; eauto.
  - unfold EncodeMEquivAlignedEncodeM, Basics.compose; intuition.
    + eapply H1; eauto.
    + edestruct H1 as [? [? [? ?] ] ].
      eapply H5; eassumption.
    + edestruct H1 as [? [? [? ?] ] ].
      eapply H6; eassumption.
    + edestruct H1 as [? [? [? ?] ] ].
      eapply H6; eassumption.
Defined.

(*Not used*)
Definition AlignEncode_Alt
           {S : Type}
           {cache : Cache}
           (encode_T encode_E : forall sz, AlignedEncodeM (S := S) sz)
           sz
  : AlignedEncodeM sz :=
  fun v idx s c => match (encode_T sz) v idx s c with
                   | Ok a' => Ok a'
                   | Error e => encode_E sz v idx s c (*TODO: This should be tagged with an error,
                                                        in case it fails we get a better traceback.
                                                        *)
                   end.

(*Lemma CorrectAlignedEncoderEither_Both
      {S : Type}
      {cache : Cache}
      (format_T format_E : FormatM S ByteString)
      (encode_T encode_E : forall sz, AlignedEncodeM sz)
  : CorrectAlignedEncoder format_T encode_T
    -> CorrectAlignedEncoder format_E encode_E
    -> CorrectAlignedEncoder
         (composeIf format_T format_E)
         (AlignEncode_Alt encode_T encode_E).
Proof.
  intros.
  destruct X as [? [? [? ?] ] ].
  destruct X0 as [? [? [? ?] ] ].
  eexists (fun s ce => Ifopt x s ce as a' Then
                                          Ifopt x0 s ce as a'' Then (If (Nat.ltb (length_ByteString (fst a')) (length_ByteString (fst a''))) Then Some a' Else Some a'')
                                                               Else Some a' Else x0 s ce); intuition.
  - destruct (x s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *.
    destruct (x0 s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *.
    destruct (length_ByteString
             {|
             padding := padding;
             front := front;
             paddingOK := paddingOK;
             numBytes := numBytes;
             byteString := byteString |} <?
           length_ByteString
             {|
             padding := padding0;
             front := front0;
             paddingOK := paddingOK0;
             numBytes := numBytes0;
             byteString := byteString0 |}) eqn: ?; simpl in H5.
    + injections; subst.
      unfold composeIf, Union_Format.
      intros ? ?; apply unfold_computes; eexists Fin.F1; simpl; eauto.
      eapply H; eauto.
    + injections; subst;
        unfold composeIf, Union_Format.
      intros ? ?; apply unfold_computes; eexists (Fin.FS Fin.F1); simpl; eauto.
      eapply H2; eauto.
    + injections; subst.
      unfold composeIf, Union_Format.
      intros ? ?; apply unfold_computes; eexists Fin.F1; simpl; eauto.
      eapply H; eauto.
    +  injections; subst;
        unfold composeIf, Union_Format.
      intros ? ?; apply unfold_computes; eexists (Fin.FS Fin.F1); simpl; eauto.
      eapply H2; eauto.
  - destruct (x s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *.
    + destruct (x0 s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *.
      destruct (length_ByteString
             {|
             padding := padding;
             front := front;
             paddingOK := paddingOK;
             numBytes := numBytes;
             byteString := byteString |} <?
           length_ByteString
             {|
             padding := padding0;
             front := front0;
             paddingOK := paddingOK0;
             numBytes := numBytes0;
             byteString := byteString0 |}) eqn: ?; simpl in H5; try discriminate.
      discriminate.
    + unfold composeIf, Union_Format in H6;
        rewrite unfold_computes in H6.
      destruct_ex.
      revert H6; pattern x1.
      eapply IterateBoundedIndex.Lookup_Iterate_Dep_Type; simpl.
      econstructor; intros.
      eapply H in Heqo; eauto.
      econstructor; intros.
      eapply H2 in H5; eauto.
      constructor.
  - destruct (x s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *; try discriminate.
    + destruct (x0 s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *.
      * destruct (length_ByteString
                    {|
                      padding := padding;
                      front := front;
                      paddingOK := paddingOK;
                      numBytes := numBytes;
                      byteString := byteString |} <?
                  length_ByteString
                    {|
                      padding := padding0;
                      front := front0;
                      paddingOK := paddingOK0;
                      numBytes := numBytes0;
                      byteString := byteString0 |}) eqn: ?; simpl in H5.
        -- injections.
           eapply H0 in Heqo; simpl in *; eauto.
        -- injections.
           eapply H3 in Heqo0; simpl in *; eauto.
      * injections.
        eapply H0 in Heqo; simpl in *; eauto.
    + eapply H3 in H5; simpl in *; eauto.
  - unfold EncodeMEquivAlignedEncodeM; intros.
    unfold AlignEncode_Alt.
    destruct (x s env) as [ [ [? ?] ? ] | ] eqn: ?.
    + destruct (x0 s env) as [ [ [? ?] ? ] | ] eqn: ?; simpl in *.
      destruct (length_ByteString
                    {|
                      padding := padding;
                      front := front;
                      paddingOK := paddingOK;
                      numBytes := numBytes;
                      byteString := byteString |} <?
                  length_ByteString
                    {|
                      padding := padding0;
                      front := front0;
                      paddingOK := paddingOK0;
                      numBytes := numBytes0;
                      byteString := byteString0 |}) eqn: ?; simpl.
      * unfold EncodeMEquivAlignedEncodeM in *.
          specialize (H1 env s idx); injections.
          simpl If_Opt_Then_Else; intuition eauto.
        -- injections.
           specialize (H5 _ _ Heqo H9 v1 v m v2); simpl in *.
           destruct H5; intuition.
           eexists _; rewrite H7; simpl; split; eauto.
        -- injections.
           specialize (H1 _ _ _ v Heqo H9); simpl in *.
           rewrite H1; simpl.
           specialize (H4 env s idx); eapply (proj1 (proj2 H4)); eauto.
           eapply PeanoNat.Nat.ltb_lt in Heqb.
           lia.
        -- injections.
           apply H0 in Heqo.
           rewrite Heqo in H9; intuition.
        -- discriminate.
      * unfold EncodeMEquivAlignedEncodeM in *.
          specialize (H4 env s idx); injections.
          simpl If_Opt_Then_Else; intuition eauto.
        -- injections.
           specialize (H5 _ _ Heqo0 H9 v1 v m v2); simpl in *.
           destruct H5; intuition.
           eexists _; rewrite H7; simpl; split; eauto.
        -- injections.
           specialize (H1 _ _ _ v Heqo H9); simpl in *.
           rewrite H1; simpl.
           specialize (H4 env s idx); eapply (proj1 (proj2 H4)); eauto.
           eapply PeanoNat.Nat.ltb_lt in Heqb.
           lia.
        -- injections.
           apply H0 in Heqo.
           rewrite Heqo in H9; intuition.
        -- discriminate.
    + simpl; specialize (H4 env s idx); specialize (H1 env s idx);
        intuition.
      * rewrite H10; simpl; eauto.
      * rewrite H10; simpl; eauto.
      * rewrite H10; simpl; eauto.
      * rewrite H10; simpl; eauto.
Qed. *)

Lemma CorrectAlignedEncoderEither_E
      {S : Type}
      {cache : Cache}
      (format_T format_E : FormatM S ByteString)
      (encode : forall sz, AlignedEncodeM sz)
      (encode_E_OK : CorrectAlignedEncoder format_E encode)
  : (forall s env, exists (v : ByteString * CacheFormat), projT1 encode_E_OK s env = Ok v)
    -> CorrectAlignedEncoder
         (composeIf format_T format_E)
         encode.
Proof.
  intros; eapply refine_CorrectAlignedEncoder; eauto.
  unfold composeIf, Union_Format; split; intros.
  - intros ? ?; apply unfold_computes; eexists (Fin.FS Fin.F1); simpl; eauto.
  - intros ? ;
      specialize (H s env); destruct_ex.
    apply (H0 x); eauto.
    destruct x.
    apply (proj1 (projT2 encode_E_OK)) in H; eapply H.
    eauto.
Defined.

Lemma CorrectAlignedEncoderEither_T
      {S : Type}
      {cache : Cache}
      (format_T format_E : FormatM S ByteString)
      (encode : forall sz, AlignedEncodeM sz)
      (encode_T_OK : CorrectAlignedEncoder format_T encode)
  : (forall s env, exists (v : ByteString * CacheFormat), projT1 encode_T_OK s env = Ok v)
    -> CorrectAlignedEncoder
         (composeIf format_T format_E)
         encode.
Proof.
  intros; eapply refine_CorrectAlignedEncoder; eauto.
  unfold composeIf, Union_Format; split; intros.
  - intros ? ?; apply unfold_computes; eexists Fin.F1; simpl; eauto.
  - intros ? ;
      specialize (H s env); destruct_ex.
    apply (H0 x); eauto.
    destruct x.
    apply (proj1 (projT2 encode_T_OK)) in H; eapply H.
    eauto.
Defined.

Definition SetByteAt (* Sets the bytes at the specified index and sets the current index
                        to the following position. *)
           {cache : Cache}
           {cacheAddNat : CacheAdd cache nat}
           {n : nat}
           (idx' : nat)
  : AlignedEncodeM n :=
  fun v idx s ce => if (Coq.Init.Nat.ltb idx' n)
                    then Ok (set_nth' v idx' s, Datatypes.S idx', addE ce 8)
                    else Error (LabelError "Error setting byte at index" EndOfBuffer).

Declare Scope AlignedEncodeM_scope.
Delimit Scope AlignedEncodeM_scope with AlignedEncodeM.
Notation "y >> z" := (AppendAlignedEncodeM y z) : AlignedEncodeM_scope.

Local Open Scope vector_scope.

Lemma AlignedEncoder_some_inv'
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
  : forall sz (t : Vector.t Core.char sz) n1 (s : S) v ni ce ce',
    enc _ t n1 s ce = Ok (v, ni, ce') ->
    exists b ce', enc' s ce = Ok (b, ce').
Proof.
  intros. destruct (enc' s ce) eqn:?; destruct_conjs; eauto.
  eapply isError, enc_OK in Heqh.
  rewrite H in Heqh. inversion Heqh.
Qed.

Lemma AlignedEncoder_sz_destruct'
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
  : forall sz (t : Vector.t Core.char sz) n1 (s : S) v ni ce ce',
    enc _ t n1 s ce = Ok (v, ni, ce') ->
    forall b ce', enc' s ce = Ok (b, ce') ->
    sz = n1 + (numBytes b + (sz-(n1+numBytes b))).
Proof.
  intros.
  destruct (Nat.le_decidable (1 + sz) (numBytes b + n1)).
  edestruct enc_OK as [_ [? _]].
  eapply H2 in H0.
  { rewrite H in H0; inversion H0. }
  rewrite length_ByteString_no_padding by eauto. lia. lia.
Qed.

Lemma AlignedEncoder_sz_destruct
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      n2
      (enc'_sz_eq : forall s ce t ce',
          enc' s ce = Ok (t, ce') -> numBytes t = n2)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
  : forall sz (t : Vector.t Core.char sz) n1 (s : S) v ni ce ce',
    enc _ t n1 s ce = Ok (v, ni, ce') ->
    sz = n1 + ((ni-n1) + (sz-ni)) /\
    n2 = ni - n1.
Proof.
  intros. edestruct @AlignedEncoder_some_inv' as [b [? ?]]; eauto.
  assert (sz = n1 + (numBytes b + (sz-(n1+numBytes b)))) by eauto using AlignedEncoder_sz_destruct'.
  revert dependent t. revert v. rewrite H1.
  intros. destruct (Vector_append_destruct3 t) as [t1 [t2 [t3 ?]]]. subst.
  edestruct enc_OK as [? _]. edestruct H2; eauto. clear H2. destruct_conjs.
  rewrite H2 in H. injections.
  split. lia.
  erewrite enc'_sz_eq; eauto. lia.
Qed.

Lemma AlignedEncoder_some_inv
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
  : forall sz (t : Vector.t Core.char sz) n1 (s : S) v ni ce ce',
    enc _ t n1 s ce = Ok (v, ni, ce') ->
    exists b , enc' s ce = Ok (b, ce').
Proof.
  intros. edestruct @AlignedEncoder_some_inv' as [b [? ?]]; eauto.
  assert (sz = n1 + (numBytes b + (sz-(n1+numBytes b)))) by eauto using AlignedEncoder_sz_destruct'.
  revert dependent t. revert v. rewrite H1.
  intros. destruct (Vector_append_destruct3 t) as [t1 [t2 [t3 ?]]]. subst.
  edestruct enc_OK as [? _]. edestruct H2; eauto. clear H2. destruct_conjs.
  rewrite H2 in H. injections.
  rewrite H0. eexists. repeat f_equal.
Qed.

Lemma AlignedEncoder_inv'
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
      n1 n3
  : forall s ce b ce'',
    enc' s ce = Ok (b, ce'') ->
    forall (t1 : Vector.t Core.char n1) (t2 : Vector.t Core.char (numBytes b))
      (t3 : Vector.t Core.char n3) v idx ce',
      enc _ (t1++t2++t3) n1 s ce = Ok (v, idx, ce') ->
      exists v2,
        enc _ t2 0 s ce = Ok (v2, numBytes b, ce') /\
        v = t1 ++ v2 ++ t3 /\
        idx = n1 + numBytes b /\
        b = build_aligned_ByteString v2 /\
        ce'' = ce'.
Proof.
  intros.
  edestruct enc_OK as [? _].
  edestruct H1; eauto. clear H1. destruct_conjs.
  rewrite H1 in H0. injections.
  edestruct enc_OK with (idx:=0) as [? _].
  edestruct H0 with (m:=0) (v0:=t2) (v1:=Vector.nil Core.char) (v2:=Vector.nil Core.char); eauto.
  clear H0. simpl in *. destruct_conjs.
  revert H0. rewrite Vector_append_nil_r'. generalize (plus_n_O (numBytes b)).
  destruct e. simpl. intros.
  assert (b = build_aligned_ByteString x) as L. {
    rewrite <- H3.
    rewrite !build_aligned_ByteString_nil.
    eauto using mempty_left.
  }
  eexists; intuition eauto.
  apply build_aligned_ByteString_inj.
  rewrite !build_aligned_ByteString_append.
  rewrite <- H2. repeat f_equal. eauto.
Qed.

Lemma AlignedEncoder_inv
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
      n
  : forall (t : Vector.t Core.char n) n1 s ce v idx ce',
      enc _ t n1 s ce = Ok (v, idx, ce') ->
      exists n2 n3 (t1 : Vector.t Core.char n1)
        (t2 : Vector.t Core.char n2) (t3 : Vector.t Core.char n3) v2
        (pf : n1 + (n2 + n3) = n),
        enc _ t2 0 s ce = Ok (v2, n2, ce') /\
        idx = n1 + n2 /\
        t = eq_rect _ _ (t1 ++ t2 ++ t3) _ pf /\
        v = eq_rect _ _ (t1 ++ v2 ++ t3) _ pf /\
        enc' s ce = Ok (build_aligned_ByteString v2, ce').
Proof.
  intros. edestruct @AlignedEncoder_some_inv' as [b [? Heqo]]; eauto.
  pose proof Heqo as Hsz. eapply AlignedEncoder_sz_destruct' in Hsz; eauto.
  revert dependent t. revert dependent v. rewrite Hsz. intros.
  destruct (Vector_append_destruct3 t) as [t1 [t2 [t3 ?]]]. subst.
  edestruct @AlignedEncoder_inv'; eauto. destruct_conjs. subst.
  repeat eexists; eauto;
    try (rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; apply Nat.eq_dec).
  congruence.
  Unshelve.
  lia.
Qed.

Lemma AlignedEncoder_extr
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
      n n'
  : forall (t : Vector.t Core.char n) (t' : Vector.t Core.char n')
      n1 s v ce idx ce',
    enc _ t n1 s ce = Ok (v, idx, ce') ->
    enc _ (t++t') n1 s ce = Ok (v++t', idx, ce').
Proof.
  intros. edestruct @AlignedEncoder_inv as [n2 [n3 [t1 [t2 [t3 [v2 ?]]]]]]; eauto.
  destruct_conjs.
  subst. simpl in *.
  match goal with
  | |- enc (?n1 + (?n2 + ?n3) + ?n4) ((?t1 ++ ?t2 ++ ?t3) ++ ?t4) ?a ?b ?c =
    Ok ((?t1' ++ ?t2' ++ ?t3') ++ ?t4', ?d, ?e)=>
    assert (enc (n1 + (n2 + (n3 + n4))) (t1 ++ t2 ++ (t3 ++ t4)) a b c =
            Ok ((t1' ++ t2' ++ (t3' ++ t4')), d, e))
  end.
  assert (n2 = numBytes (build_aligned_ByteString v2)) as L by eauto.
  edestruct enc_OK as [? _]. edestruct H0 with (v:=eq_rect _ _ t2 _ L); eauto. clear H0. destruct_conjs.
  destruct L. simpl in *. rewrite H0.
  repeat f_equal. apply build_aligned_ByteString_inj.
  rewrite <- H2. rewrite !build_aligned_ByteString_append. reflexivity.

  rename n' into n4. revert H0. clear. intros.
  assert (n1 + (n2 + n3) + n4 = n1 + (n2 + (n3 + n4))) by lia.
  assert (forall {A}
            (t1 : Vector.t A n1) (t2 : Vector.t A n2) (t3 : Vector.t A n3) (t4 : Vector.t A n4),
             t1 ++ t2 ++ t3 ++ t4 = eq_rect _ (Vector.t A) ((t1 ++ t2 ++ t3) ++ t4) _ H) as L. {
    clear. intros.
    assert (n2 + n3 + n4 = n2 + (n3 + n4)) by lia.
    rewrite <- (Vector_append_assoc' _ _ _ _ H0). f_equal.
    apply Vector_append_assoc.
  }
  revert H0. rewrite !L. clear. destruct H. simpl. eauto.
Qed.

Corollary AlignedEncoder_inv2
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
      n
  : forall (t : Vector.t Core.char n) n1 s ce v idx ce',
      enc _ t n1 s ce = Ok (v, idx, ce') ->
      exists n2 n3 (t1 : Vector.t Core.char n1) (t23 : Vector.t Core.char (n2+n3)) v23
        (pf : n1 + (n2+n3) = n),
        enc _ t23 0 s ce = Ok (v23, n2, ce') /\
        idx = n1 + n2 /\
        t = eq_rect _ _ (t1 ++ t23) _ pf /\
        v = eq_rect _ _ (t1 ++ v23) _ pf.
Proof.
  intros. edestruct @AlignedEncoder_inv; eauto. destruct_conjs.
  repeat eexists; eauto. eauto using AlignedEncoder_extr.
Qed.

Corollary AlignedEncoder_inv0
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
      n
  : forall (t : Vector.t Core.char n) s ce v ce',
    enc _ t 0 s ce = Ok (v, n, ce') ->
    enc' s ce = Ok (build_aligned_ByteString v, ce').
Proof.
  intros. edestruct @AlignedEncoder_inv as [n2 [n3 [t1 [t2 [t3 [v2 ?]]]]]]; eauto.
  destruct_conjs. subst. simpl in *.
  rewrite H5. repeat f_equal.
  assert (n3 = 0) by lia. subst. clear.
  apply Vector.case0 with (v:=t1). simpl.
  apply Vector.case0 with (v:=t3).
  rewrite Vector_append_nil_r'. generalize (plus_n_O n2). destruct e.
  reflexivity.
Qed.

Lemma AlignedEncoder_none_inv
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
  : forall s ce b ce'
      sz (t : Vector.t Core.char sz) n1,
    enc' s ce = Ok (b, ce') ->
    is_error (enc _ t n1 s ce) ->
    (sz < n1 + numBytes b)%nat.
Proof.
  intros.
  destruct (Nat.le_decidable (1 + sz) (numBytes b + n1)). lia.
  assert (sz = n1 + (numBytes b + (sz - (n1+numBytes b)))) by lia.
  revert dependent t. rewrite H2. intros. destruct (Vector_append_destruct3 t) as [t1 [t2 [t3 ?]]].
  subst.
  edestruct enc_OK as [? _]. edestruct H3; eauto. clear H3. destruct_conjs.
  rewrite H3 in H0. inversion H0.
Qed.

Lemma AlignedEncoder_extl
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
  : forall n (t : Vector.t Core.char n) n1 s ce v ce',
    enc _ t 0 s ce = Ok (v, n1, ce') ->
    forall idx (t1 : Vector.t Core.char idx),
    enc _ (t1++t) idx s ce = Ok (t1++v, idx+n1, ce').
Proof.
  intros.
  match goal with
  | |- ?a = _ => destruct a eqn:?
  end. destruct_conjs.
  edestruct @AlignedEncoder_inv2 as [n2 [n3 [t2 [t23 [v23 ?]]]]]; try apply Heqo; eauto.
  destruct_conjs. assert (n2 + n3 = n) as L by lia. destruct L.
  rewrite <- Eqdep_dec.eq_rect_eq_dec in H3 by (apply Nat.eq_dec).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in H4 by (apply Nat.eq_dec).
  subst.
  apply Vector_append_inj in H3. destruct_conjs. subst.
  edestruct @AlignedEncoder_some_inv; try apply H; eauto.
  edestruct @AlignedEncoder_some_inv; try apply H1; eauto.
  substss. injections. eauto.
  exfalso.
  edestruct @AlignedEncoder_some_inv; try apply H; eauto.
  eapply isError, AlignedEncoder_none_inv in Heqh; eauto.
  eapply AlignedEncoder_sz_destruct' in H; eauto.
  lia.
Qed.

Lemma AlignedEncoder_fixed
      {S} {cache : Cache}
      (enc' : EncodeM S ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
      (enc'_aligned : forall s ce t ce', enc' s ce = Ok (t, ce') -> padding t = 0)
      n n1
  : forall (t : Vector.t Core.char n)
      s ce v idx ce',
    enc _ t n1 s ce = Ok (v, idx, ce') ->
    enc _ v n1 s ce = Ok (v, idx, ce').
Proof.
  intros. edestruct @AlignedEncoder_inv as [n2 [n3 [t1 [t2 [t3 [v2 ?]]]]]]; eauto.
  destruct_conjs.
  subst. simpl in *.
  assert (n2 = numBytes (build_aligned_ByteString v2)) as L by eauto.
  match goal with
  | |- ?x = _ => destruct x eqn:?
  end. destruct_conjs.
  edestruct @AlignedEncoder_inv'; try apply Heqo; eauto. destruct_conjs.
  subst. repeat f_equal. eauto using build_aligned_ByteString_inj.
  exfalso. eapply isError, AlignedEncoder_none_inv in Heqh; eauto.
  lia.
Qed.

Lemma AlignedEncoder_append_inv
      {S} {cache : Cache}
      (enc1' : EncodeM S ByteString)
      (enc1 : forall sz, AlignedEncodeM sz)
      (enc1_OK : EncodeMEquivAlignedEncodeM enc1' enc1)
      (enc1'_aligned : forall s ce t ce', enc1' s ce = Ok (t, ce') -> padding t = 0)
      (enc2' : EncodeM S ByteString)
      (enc2 : forall sz, AlignedEncodeM sz)
      (enc2_OK : EncodeMEquivAlignedEncodeM enc2' enc2)
      (enc2'_aligned : forall s ce t ce', enc2' s ce = Ok (t, ce') -> padding t = 0)
      n
  : forall (t : Vector.t Core.char n) s ce v idx ce',
    (enc1 n >> enc2 n)%AlignedEncodeM t 0 s ce = Ok (v, idx, ce') ->
    exists n1 n2 n3 (t1 : Vector.t Core.char n1) (t23 : Vector.t Core.char (n2+n3)) v1 v23 ce''
      (pf : n1 + (n2+n3) = n),
      enc1 _ t1 0 s ce = Ok (v1, n1, ce'') /\
      enc2 _ t23 0 s ce'' = Ok (v23, n2, ce') /\
      idx = n1 + n2 /\
      t = eq_rect _ _ (t1 ++ t23) _ pf /\
      v = eq_rect _ _ (v1 ++ v23) _ pf.
Proof.
  unfold AppendAlignedEncodeM. intros.
  destruct enc1 eqn:?; [| discriminate]; destruct_conjs; simpl in *.
  destruct enc2 eqn:?; [| discriminate]; destruct_conjs; simpl in *.
  injections. rename n0 into n1. rename t0 into v0.
  edestruct @AlignedEncoder_inv as [n1' [n23 [tnil [t1 [t23 [v1 ?]]]]]]; try apply enc1_OK; eauto.
  destruct_conjs. subst. simpl in *.
  revert dependent tnil. intros tnil.
  apply Vector.case0 with (v:=tnil). clear tnil. simpl. intros. rename n1' into n1.
  edestruct @AlignedEncoder_inv2 as [n2 [n3 [v1' [t23' [v23 ?]]]]]; try apply enc2_OK; eauto.
  destruct_conjs. assert (n2 + n3 = n23) by lia. destruct H6.
  rewrite <- Eqdep_dec.eq_rect_eq_dec in H3 by (apply Nat.eq_dec).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in H5 by (apply Nat.eq_dec).
  subst. apply Vector_append_inj in H3. destruct_conjs. subst.
  repeat eexists; eauto.
  instantiate (1:=eq_refl). all : eauto.
Qed.

Lemma sequence_Encoding_padding_0
      {cache : Cache} {S : Type}
      enc1 enc2
      (enc1_aligned : forall s ce t ce', enc1 s ce = Ok (t, ce') -> padding t = 0)
      (enc2_aligned : forall s ce t ce', enc2 s ce = Ok (t, ce') -> padding t = 0)
  : forall s ce b ce',
    @sequence_Encode ByteString cache _ S enc1 enc2 s ce = Ok (b, ce') -> padding b = 0.
Proof.
  unfold sequence_Encode. intros.
  destruct enc1 eqn:?; destruct_conjs; [| discriminate]; simpl in *.
  destruct enc2 eqn:?; destruct_conjs; [| discriminate]; simpl in *.
  injections. apply enc1_aligned in Heqh. apply enc2_aligned in Heqh0.
  rewrite ByteString_enqueue_ByteString_padding_eq. rewrite Heqh. rewrite Heqh0.
  reflexivity.
Qed.

Lemma sequence_Encoding_inv
      {cache : Cache} {S : Type}
      enc1 enc2
  : forall s ce b ce',
    @sequence_Encode ByteString cache _ S enc1 enc2 s ce = Ok (b, ce') ->
    exists b1 b2 ce1,
      enc1 s ce = Ok (b1, ce1) /\
      enc2 s ce1 = Ok (b2, ce') /\
      b = mappend b1 b2.
Proof.
  unfold sequence_Encode. intros.
  destruct enc1 eqn:?; destruct_conjs; [| discriminate]; simpl in *.
  destruct enc2 eqn:?; destruct_conjs; [| discriminate]; simpl in *.
  injections. eauto 10.
Qed.

Definition EncodeAgain {S : Type} {cache : Cache}
           {n}
           (a : @AlignedEncodeM _ S n)
           (b : nat -> @AlignedEncodeM _ S n)
  : @AlignedEncodeM _ S n :=
  fun v idx s c => (HBind a v idx s c  as a' With
                    (HBind b (snd (fst a')) (fst (fst a')) idx s c as b' With
                       Ok (fst (fst b'), snd (fst a'), snd b')
                       )
                    ).

Lemma EncodeMEquivAlignedEncodeMDep
      {S A} {cache : Cache}
      (enc1' : EncodeM S ByteString)
      (enc2' : A -> EncodeM S ByteString)
      (f' : ByteString -> A)
      (enc1 : forall sz, AlignedEncodeM sz)
      (enc2 : A -> forall sz, AlignedEncodeM sz)
      (f : nat -> forall {sz}, Vector.t (word 8) sz -> nat -> A)
      (enc1_OK : EncodeMEquivAlignedEncodeM enc1' enc1)
      (enc2_OK : forall a, EncodeMEquivAlignedEncodeM (enc2' a) (enc2 a))
      (enc1'_aligned : forall s ce t ce', enc1' s ce = Ok (t, ce') -> padding t = 0)
      (enc2'_aligned : forall a s ce t ce', enc2' a s ce = Ok (t, ce') -> padding t = 0)
      (enc'_sz_eq : forall s a ce t1 ce1 t2 ce2,
          enc1' s ce = Ok (t1, ce1) ->
          enc2' a s ce = Ok (t2, ce2) ->
          bin_measure t1 = bin_measure t2)
      (f_OK : forall (b : ByteString)
                idx (v1 : Vector.t Core.char idx)
                m (v2 : Vector.t Core.char m)
                (v : Vector.t Core.char (idx + ((numBytes b) + m))),
          ByteString_enqueue_ByteString (build_aligned_ByteString v1)
                                        (ByteString_enqueue_ByteString b (build_aligned_ByteString v2))
          = build_aligned_ByteString v ->
          f' b = f (numBytes b) v idx)
  : EncodeMEquivAlignedEncodeM
      (fun s ce =>
         `(p, _) <- enc1' s ce;
           enc2' (f' p) s ce)
      (fun sz => EncodeAgain (enc1 sz)
                          (fun idx' v idx s =>
                             enc2 (f (idx'-idx) v idx) sz v idx s))%AlignedEncodeM.
Proof.
  (*
  repeat split; intros; simpl in *. {
    destruct enc1' eqn:?; [| discriminate]; destruct_conjs; simpl in *.
    assert (numBytes b = numBytes t) as L1. {
      assert (bin_measure b = bin_measure t) by eauto.
      rewrite !length_ByteString_no_padding in H1 by eauto.
      lia.
    }

    edestruct enc1_OK as [? _]. specialize (H1 _ _ Heqe).
    revert H1. rewrite L1. intros.
    edestruct (H1 (enc1'_aligned _ _ _ _ Heqe) v1 v _ v2); eauto. clear H1. destruct_conjs.

    assert (exists v, v1 ++ v ++ v2 = x) as L2. {
      destruct L1.
      edestruct @AlignedEncoder_inv'; eauto; eauto. destruct_conjs.
      eauto.
    } destruct L2 as [v' L2].

    edestruct enc2_OK as [? _]. specialize (H3 _ _ H).
    edestruct H3; eauto. clear H3. destruct_conjs.
    rewrite L2 in H3.

    eexists. split; eauto. unfold EncodeAgain.
    rewrite H1. simpl.
    match goal with
    | H : enc2 ?a _ _ _ _ _ = _ |- context[enc2 ?a' _ _ _ _ _] =>
      replace a' with a
    end.
    rewrite H3. simpl. reflexivity.
    destruct L1. replace (idx + numBytes b - idx) with (numBytes b) by lia. eauto.
  } {
    destruct enc1' eqn:?; [| discriminate]; destruct_conjs; simpl in *.
    edestruct enc1_OK as [_ [? _]]. eapply H1 in Heqe.
    unfold EncodeAgain. rewrite Heqe. reflexivity.
    assert (bin_measure b = bin_measure t) as L1 by eauto. simpl in *.
    congruence.
  } {
    destruct enc1' eqn:?; [| discriminate]; destruct_conjs; simpl in *.
    exfalso. eauto.
  } {
    destruct enc1' eqn:?; destruct_conjs; simpl in *; unfold EncodeAgain. {
      destruct (Nat.le_decidable (1 + numBytes') (numBytes b + idx)).
      edestruct enc1_OK as [_ [? _]]. erewrite H1; eauto.
      rewrite length_ByteString_no_padding by eauto. lia.
      assert (exists m, numBytes' = idx + (numBytes b + m)). {
        exists (numBytes' - (idx + numBytes b)). lia.
      } destruct H1 as [m ?]. subst.
      edestruct (enc1_OK env s idx) as [? _]; eauto.
      edestruct H1; eauto. destruct_conjs.
      match goal with
      | H : enc1 _ ?v' _ _ _ = _ |- _ => replace v with v'
      end. rewrite H2. simpl.
      edestruct enc2_OK as [_ [_ [_ ?]]]. rewrite H4; eauto.
      simpl.
      (* simpl. rewrite <- H. f_equal. *)
      replace (idx + numBytes b - idx) with (numBytes b) by lia.
      erewrite <- f_OK; eauto.
      repeat (rewrite Vector_split_append; f_equal).
    } {
      edestruct (enc1_OK env s idx) as [_ [_ [_ ?]]]; eauto. eapply isError, H0 in Heqe; eauto.
      rewrite Heqe. reflexivity.
    }
  }
Qed.
   *)
  Admitted.
Lemma EncodeMEquivAlignedEncodeM_const
      {S A} {cache : Cache}
      (enc' : EncodeM A ByteString)
      (enc : forall sz, AlignedEncodeM sz)
      (enc_OK : EncodeMEquivAlignedEncodeM enc' enc)
  : forall a, EncodeMEquivAlignedEncodeM (S:=S)
           (fun _ ce => enc' a ce)
           (fun sz v n _ ce => enc sz v n a ce).
Proof.
  intros. repeat split; simpl; intros;
            edestruct enc_OK as [? [? [? ?]]]; eauto.
Qed.

(* This provides a more convenient side-condition used in some aligned encoder,
e.g., list and vector. *)
Lemma encoder_format_eq_cache_OK {cache : Cache} {S1 S2}
        (format_A : FormatM S1 ByteString)
        (format_B : FormatM S2 ByteString)
        (encode_B : forall sz, AlignedEncodeM sz)
        (encoder_B_OK : CorrectAlignedEncoder format_B encode_B)
        (encode_A_OK' : forall (s1 : S1) (s2 : S2) (env: CacheFormat)
                          (tenv' tenv'' tenv3 : ByteString * CacheFormat),
            format_B s2 env ∋ tenv' ->
            format_A s1 (snd tenv') ∋ tenv'' ->
            projT1 encoder_B_OK s2 env = Ok tenv3 ->
            snd tenv' = snd tenv3)
    : forall (s1 : S1) (s2 : S2) (env : CacheFormat) (tenv' tenv'' : ByteString * CacheFormat),
      format_B s2 env ∋ tenv' ->
      format_A s1 (snd tenv') ∋ tenv'' ->
      exists tenv3 tenv4 : _ * CacheFormat,
        projT1 encoder_B_OK s2 env = Ok tenv3
        /\ format_A s1 (snd tenv3) ∋ tenv4.
Proof.
  intros.
  match goal with
  | |- exists _ _, ?e = _ /\ _ => destruct e eqn:?
  end.
  - repeat esplit. erewrite <- encode_A_OK'; eauto.
  - exfalso. destruct encoder_B_OK as [? [H' ?]]; simpl in *.
    eapply H'; eauto. rewrite Heqh; constructor.
Qed.


From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight.
From compcert Require Import Maps Values ClightBigstep Events Clightdefs.

Require Import Clight.intmax_test.

Open Scope Z_scope.

Definition spec := 2.

Theorem f_intmax_test_correct (ge : genv) (e : env) (m : Memory.Mem.mem) :
  forall (ste : temp_env) (n1 n2 : Z),
    (* starting environment *)
    ste ! _a = Some (Vlong (Int64.repr 1)) ->
    ste ! _b = Some (Vlong (Int64.repr 1)) ->

    (* correct return *)
    exists (t : trace) (rte : temp_env),
      exec_stmt ge e ste m f_long_test.(fn_body) t rte m
        (Out_return (Some (Vundef, tvoid))).


Record PreCategory :=  Build_PreCategory' { object :> Type }.
Class Foo (X : Type) := {}.
Class Bar := {}.
Definition functor_category `{Bar} (C D : PreCategory)  `{Foo (object D)} : PreCategory.
Admitted.
Fail Definition functor_object_of `{Bar} (C1 C2 D : PreCategory) `{Foo (object D)}
: functor_category C1 (functor_category C2 D) -> True.
(** Anomaly: File "toplevel/himsg.ml", line ..., characters ...: Assertion failed.
Please report. *)


From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri Require Import machine_extra lifting rules.rules_base.
From HypVeri.algebra Require Import base reg mem pagetable mailbox base_extra.
From HypVeri.lang Require Import lang_extra reg_extra current_extra.
Require Import stdpp.fin.
Require Import stdpp.listset_nodup.

Section run.

Context `{hypparams:HypervisorParameters}.

Context `{vmG: !gen_VMG Σ}.

Lemma run {E w1 w2 w3 q s p_tx R' Q P} ai i R P':
  let T := (▷ (PC @@ V0 ->r ai)
            ∗ ▷ (ai ->a w1)
            ∗ ▷ (V0 -@{q}A> s)
            ∗ ▷ (TX@ V0 := p_tx)
            ∗ ▷ (R0 @@ V0 ->r w2)
            ∗ ▷ (R1 @@ V0 ->r w3))%I
  in
  let T' := ((PC @@ V0 ->r (ai ^+ 1)%f)
               ∗ ai ->a w1
               ∗ V0 -@{q}A> s
               ∗ TX@ V0 := p_tx
               ∗ R0 @@ V0 ->r w2
               ∗ R1 @@ V0 ->r w3)%I
  in
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  i ≠ V0 ->
  decode_instruction w1 = Some Hvc ->
  decode_hvc_func w2 = Some Run ->
  decode_vmid w3 = Some i ->
  {SS{{ T ∗ ▷ (VMProp i (Q) (1/2)%Qp)
          ∗ ▷ (VMProp V0 P 1%Qp)
          ∗ ▷ (T' ∗ R ∗ VMProp V0 P' (1/2)%Qp -∗ (Q ∗ R'))
          ∗ ▷ R }}}
    ExecI @ V0 ;E
    {{{ RET (true, ExecI); R' ∗ VMProp V0 P' (1/2)%Qp}}}.
Proof.
  simpl.
  iIntros (Hin Hnottx Hneq_v Hdecode Hhvc Hvmid ϕ) "[(>Hpc & >Hapc & >Hacc & >tx & >Hr0 & >Hr1) (HPropi & HPropz & Himpl & HR)] Hϕ".
  iApply (sswp_lift_atomic_step ExecI); [done|].
  iIntros (n σ1) "%Hsche Hσ".
  rewrite /scheduled in Hsche.
  simpl in Hsche.
  rewrite /scheduler in Hsche.
  apply bool_decide_unpack in Hsche as Hcur.
  clear Hsche.
  apply fin_to_nat_inj in Hcur.
  iModIntro.
  iDestruct "Hσ" as "(%Hneq & Hmemown & Hreg & Hmb & ? & Hown & Haccessown & Hrest)".
  (* valid regs *)
  iDestruct (gen_reg_valid1 PC V0 ai Hcur with "Hreg Hpc") as "%Hpc".
  iDestruct (gen_reg_valid1 R0 V0 w2 Hcur with "Hreg Hr0") as "%Hr0".
  iDestruct (gen_reg_valid1 R1 V0 w3 Hcur with "Hreg Hr1") as "%Hr1".
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai)  with "Haccessown Hacc") as %Hacc;first exact Hin.
  iDestruct (mb_valid_tx with "Hmb tx") as %Htx.
  subst p_tx.
  (* valid mem *)
  iDestruct (gen_mem_valid ai w1 with "Hmemown Hapc") as "%Hmem".
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal V0 Hvc ai w1);eauto.
  - iModIntro.
    iIntros (m2 σ2) "[%U PAuth] %HstepP".
    apply (step_ExecI_normal V0 Hvc ai w1) in HstepP; eauto.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc in Heqc2; eauto.
    rewrite  Hr0 /= Hhvc /run Hr1 in Heqc2.
    simpl in Heqc2.
    rewrite /unpack_hvc_result_yield Hvmid in Heqc2.
    simpl in Heqc2.
    rewrite /is_primary Hcur in Heqc2.
    destruct HstepP as [Hstep1 Hstep2].
    case_bool_decide;last done.
    subst c2.
    simpl in Hstep1, Hstep2.
    subst σ2 m2.
    simpl.
    rewrite /gen_vm_interp /update_incr_PC.
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    all: try rewrite p_upd_id_mb p_upd_pc_mb //.
    all: try rewrite p_upd_id_pgt p_upd_pc_pgt //.
    all: try rewrite p_upd_id_trans p_upd_pc_trans //.
    rewrite p_upd_id_mem p_upd_pc_mem.
    iFrame.
    iDestruct ((gen_reg_update1_global PC V0 ai (ai ^+ 1)%f) with "Hreg Hpc") as "HpcUpd".
    rewrite (preserve_get_reg_gmap (update_offset_PC σ1 1) (update_current_vmid _ _));last rewrite p_upd_id_reg //.
    rewrite ->(u_upd_pc_regs _ V0 ai 1); auto.
    + iDestruct (VMProp_update V0 U P P' with "PAuth HPropz") as "HTemp".
      iMod "HpcUpd".
      iMod "HTemp".
      iDestruct "HTemp" as "[PAuth HPropz]".
      iModIntro.
      iDestruct "HpcUpd" as "[? Hpc]".
      iFrame.
      iSplitL "PAuth".
      by iExists P'.
      iSplit; first done.
      rewrite /just_scheduled_vms /just_scheduled.
      assert (filter
                (λ id : vmid,
                        base.negb (scheduled σ1 id) &&
                        scheduled (update_current_vmid (update_offset_PC σ1 1) i) id = true)
                (seq 0 n) = [fin_to_nat i]) as ->.
      {
        rewrite /scheduled /machine.scheduler Hneq //= /scheduler.
        rewrite /update_current_vmid //=.
        pose proof (NoDup_seq 0 vm_count) as ND.
        pose proof (NoDup_singleton ((@fin_to_nat (@vm_count H) i))) as ND'.
        set f := (λ id : nat, base.negb (bool_decide ((@fin_to_nat (@vm_count H) σ1.1.1.2) = id)) && bool_decide ((@fin_to_nat (@vm_count H) i) = id) = true).
        pose proof (NoDup_filter f _ ND) as ND''.
        assert (f i) as Prf.
        {
          subst f.
          simpl.
          unfold base.negb.
          repeat case_bool_decide; eauto.
          rewrite Hcur in H1.
          exfalso.
          apply Hneq_v.
          symmetry.
          apply fin_to_nat_inj.
          done.
        }
        assert (In (@fin_to_nat (@vm_count H) i) (seq 0 vm_count)) as Prf'.
        {
          rewrite <-elem_of_list_In.
          rewrite elem_of_seq.
          split.
          - solve_finz.
          - rewrite plus_O_n.
            pose proof (fin_to_nat_lt i).
            auto.
        }
        rewrite <-elem_of_list_In in Prf'.
        assert (In (@fin_to_nat (@vm_count H) i) (filter f (seq 0 vm_count))) as Prf''.
        {
          rewrite <-elem_of_list_In.
          by apply (iffRL (elem_of_list_filter f (seq 0 vm_count) i)).
        }
        rewrite <-elem_of_list_In in Prf''.
        assert (forall x, x ≠ (@fin_to_nat (@vm_count H) i) -> not (In x (filter f (seq 0 vm_count)))) as excl.
        {
          intros x neq c.
          rewrite <-elem_of_list_In in c.
          rewrite ->elem_of_list_filter in c.
          destruct c as [c' _].
          subst f.
          simpl in c'.
          unfold base.negb in c'.
          case_match.
          - by rewrite andb_false_l in c'.
          - rewrite andb_true_l in c'.
            apply neq.
            rewrite ->bool_decide_eq_true in c'.
            by symmetry.
        }
        apply Permutation_length_1_inv.
        apply NoDup_Permutation; auto.
        intros x'.
        split.
        - intros T.
          rewrite ->elem_of_list_singleton in T.
          rewrite T; auto.
        - intros T.
          rewrite ->elem_of_list_singleton.
          rewrite ->elem_of_list_In in T.
          destruct (decide (x' = i)) as [? | n']; auto.
          exfalso.
          by apply (excl x' n').
      }
      iSimpl.
      assert ((negb (scheduled (update_current_vmid (update_offset_PC σ1 1) i) V0) && true = true)) as ->.
      {
        rewrite andb_true_r.
        rewrite /scheduled /machine.scheduler //= /scheduler.
        rewrite /update_current_vmid //=.
        apply eq_true_not_negb.
        intros c.
        rewrite ->bool_decide_eq_true in c.
        apply Hneq_v.
        apply fin_to_nat_inj.
        done.
      }
      iDestruct (VMProp_split with "HPropz") as "[HPropz1 HPropz2]".
      iDestruct ("Himpl" with "[Hpc Hapc Hacc Hr0 Hr1 HR HPropz1 tx]") as "[Q R']".
      iFrame.
      iSplitR "Hϕ R' HPropz2".
      iSplit; last done.
      iExists (Q)%I.
      iFrame.
      iApply ("Hϕ" with "[R' HPropz2]").
      iFrame.
    + apply get_reg_gmap_get_reg_Some; auto.
Qed.

Lemma run_not_primary {E wi r0 r2 q s p_tx } ai i :
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  decode_instruction wi = Some Hvc ->
  decode_hvc_func r0 = Some Run ->
  i ≠ V0 ->
  {SS{{ ▷ (PC @@ i ->r ai)
            ∗ ▷ (ai ->a wi)
            ∗ ▷ (i -@{q}A> s)
            ∗ ▷ (TX@ i := p_tx)
            ∗ ▷ (R0 @@ i ->r r0)
            ∗ ▷ (R2 @@ i ->r r2)
            }}}
    ExecI @ i ;E
    {{{ RET (false, ExecI); PC @@ i ->r (ai ^+ 1)%f
               ∗ ai ->a wi
               ∗ i -@{q}A> s
               ∗ TX@ i := p_tx
               ∗ R0 @@ i ->r (encode_hvc_ret_code Error)
               ∗ R2 @@ i ->r (encode_hvc_error Denied) }}}.
  Proof.
  iIntros (Hin_acc Hneq_tx Hdecode_i Hdecode_f Hneq_v0 Φ)
          "(>PC & >mem_ins & >acc & >tx & >R0 & >R2) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid3 i PC ai R0 r0 R2 r2 Heq_cur) with "regs PC R0 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /= /lang.run /is_primary  in Heqc2.
    case_bool_decide. rewrite H0 in Heq_cur. rewrite Heq_cur // in Hneq_v0.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    iDestruct (hvc_error_update (E:= E) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]";auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
  Qed.

Lemma run_invalid_vmid {E wi r0 r1 r2 q s p_tx } ai :
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  decode_instruction wi = Some Hvc ->
  decode_hvc_func r0 = Some Run ->
  decode_vmid r1 = None ->
  {SS{{ ▷ (PC @@ V0 ->r ai)
            ∗ ▷ (ai ->a wi)
            ∗ ▷ (V0 -@{q}A> s)
            ∗ ▷ (TX@ V0 := p_tx)
            ∗ ▷ (R0 @@ V0 ->r r0)
            ∗ ▷ (R1 @@ V0 ->r r1)
            ∗ ▷ (R2 @@ V0 ->r r2)
            }}}
    ExecI @ V0 ;E
    {{{ RET (false, ExecI); PC @@ V0 ->r (ai ^+ 1)%f
               ∗ ai ->a wi
               ∗ V0 -@{q}A> s
               ∗ TX@ V0 := p_tx
               ∗ R0 @@ V0 ->r (encode_hvc_ret_code Error)
               ∗ R1 @@ V0 ->r r1
               ∗ R2 @@ V0 ->r (encode_hvc_error InvParam) }}}.
  Proof.
  iIntros (Hin_acc Hneq_tx Hdecode_i Hdecode_f Hdecode_vmid Φ)
          "(>PC & >mem_ins & >acc & >tx & >R0 &>R1 & >R2) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = V0) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 V0 PC ai R0 r0 R1 r1 R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) V0 with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx V0 p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal V0 Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal V0 Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /= /lang.run /is_primary in Heqc2.
    case_bool_decide;last contradiction.
    rewrite Hlookup_R1 /= Hdecode_vmid /= in Heqc2.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    iDestruct (hvc_error_update (E:= E) InvParam with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]";auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
  Qed.

Lemma run_primary {E wi r0 r1 q s p_tx} ai :
  (tpa ai) ∈ s ->
  (tpa ai) ≠ p_tx ->
  decode_instruction wi = Some Hvc ->
  decode_hvc_func r0 = Some Run ->
  decode_vmid r1 = Some V0 ->
  {SS{{ ▷ (PC @@ V0 ->r ai)
            ∗ ▷ (ai ->a wi)
            ∗ ▷ (V0 -@{q}A> s)
            ∗ ▷ (TX@ V0 := p_tx)
            ∗ ▷ (R0 @@ V0 ->r r0)
            ∗ ▷ (R1 @@ V0 ->r r1)}}}
    ExecI @ V0 ;E
    {{{ RET (false, ExecI); PC @@ V0 ->r (ai ^+ 1)%f
               ∗ ai ->a wi
               ∗ V0 -@{q}A> s
               ∗ TX@ V0 := p_tx
               ∗ R0 @@ V0 ->r r0
               ∗ R1 @@ V0 ->r r1}}}.
  Proof.
  iIntros (Hin_acc Hneq_tx Hdecode_i Hdecode_f Hdecode_vmid Φ)
          "(>PC & >mem_ins & >acc & >tx & >R0 & >R1) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = V0) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid3 V0 PC ai R0 r0 R1 r1 Heq_cur) with "regs PC R0 R1")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) V0 with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx V0 p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal V0 Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal V0 Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /= /lang.run /is_primary in Heqc2.
    case_bool_decide;last contradiction.
    rewrite Hlookup_R1 /= Hdecode_vmid /= in Heqc2.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    all: try rewrite p_upd_id_mb p_upd_pc_mb //.
    all: try rewrite p_upd_id_pgt p_upd_pc_pgt //.
    all: try rewrite p_upd_id_trans p_upd_pc_trans //.
    rewrite p_upd_id_mem p_upd_pc_mem.
    iFrame.
    (* upd reg*)
    rewrite (preserve_get_reg_gmap (update_incr_PC σ1) (update_current_vmid _ _)).
    2: rewrite p_upd_id_reg //.
    rewrite (u_upd_pc_regs _ V0 ai).
    2: rewrite //.
    2: solve_reg_lookup.
    iDestruct ((gen_reg_update1_global PC V0 _ (ai ^+ 1)%f) with "regs PC")
      as ">($ & PC)";eauto.
    iModIntro.
    iSplit. iPureIntro. auto.
    (* just_schedule *)
    rewrite /just_scheduled_vms /just_scheduled.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite /update_current_vmid /= Heq_cur.
    set fl := (filter _ _).
    assert (fl = []) as ->.
    {
      rewrite /fl.
      induction n.
      - simpl.
        rewrite filter_nil //=.
      - rewrite seq_S.
        rewrite list.filter_app.
        rewrite IHn.
        simpl.
        rewrite filter_cons_False /=.
        rewrite filter_nil. auto.
        rewrite andb_negb_l.
        done.
    }
    iSplitR;first done.
    case_bool_decide; last contradiction.
    simpl.
    iApply "HΦ".
    iFrame.
  Qed.

End run.


(**
 Verified SAR-BP: A verified C implementation of SAR backprojection
 with a certified absolute error bound.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file is free software. You can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 Free Software Foundation, either version 3 of the License (GNU GPL
 v3), or (at your option) any later version.  A verbatim copy of the
 GNU GPL v3 is included in gpl-3.0.txt.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole Verified SAR-BP library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying Verified SAR-BP in your work, please
 consider citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 Verified SAR-BP derives from prior work listed in ACKS along with
 their copyright and licensing information.

 Verified SAR-BP requires third-party libraries listed in ACKS along
 with their copyright information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

Verification of C implementation of sine.
*)

Require Import Flocq.Appli.Fappli_IEEE.
Require Import Integers.
Require Import AST.
Require Import Values.
Require Import Memory.
Require Import Clight.
Require Import FPLang.
Require Import FPLangOpt.
Require Import ClightFacts.
Require Import Clight2FPOpt.
Require Import SARBackProjSource.
Require Import SARBackProjSourceSin.

Require Import RAux.
Require Import FieldEq.
Open Scope R_scope.

Transparent Integers.Int.repr.
Transparent Floats.Float32.of_bits.
Transparent Floats.Float.of_bits.
Set Printing Depth 1000000.

Local Existing Instances
      Clight2FP.nans
      map_nat compcert_map
.

Require Import Interval.Interval_tactic.
Require Import ClightSep2.

Open Scope R_scope.

Definition f_sin_cos_correct f_sin_error f_cos_error ge cef_sin_cos :=
  type_of_fundef cef_sin_cos =
  Ctypes.Tfunction (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tfloat)
                                 (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tfloat)
                                               (Ctypes.Tcons Clightdefs.tdouble Ctypes.Tnil)))
                   Clightdefs.tvoid
                   cc_default
  /\
  forall
    os
    (Hos_align: (align_chunk Mfloat32 | Int.unsigned os)%Z )
    oc
    (Hoc_align: (align_chunk Mfloat32 | Int.unsigned oc)%Z )
    ps (Hps: perm_order ps Writable)
    pc (Hpc: perm_order pc Writable)
    bs bc
    m P
    (Hm:
       holds
         (P ++
            Pperm bs (Int.unsigned os) ps (size_chunk_nat Mfloat32)
            ++
            Pperm bc (Int.unsigned oc) pc (size_chunk_nat Mfloat32))
         m)
    x
    (Hx_finite: is_finite _ _ x = true)
    (Hx_range: x_left <= B2R _ _ x <= x_right )
  ,
    let st0 := (Callstate cef_sin_cos
                          (Vptr bs os :: Vptr bc oc :: Vfloat x :: nil)
                          Kstop
                          m) in
    exists m',
      star Clight.step2 ge
           st0
           E0
           (Returnstate Vundef Kstop m')
      /\
      exists si co,
        holds
          (P ++
             Pval Mfloat32 bs (Int.unsigned os) ps (Vsingle si)
             ++
             Pval Mfloat32 bc (Int.unsigned oc) pc (Vsingle co))
          m'
        /\
        (
          is_finite _ _ si = true
          /\
          is_finite _ _ co = true
        )
        /\
        (
          Rabs (B2R _ _ si - sin (B2R _ _ x)) <= f_sin_error
          /\
          Rabs (B2R _ _ co - cos (B2R _ _ x)) <= f_cos_error
        )
.

Lemma round_to_error u v d e:
  v = u * (1 + d) + e ->
  v - u = u * d + e.
Proof.
  intros H.
  subst.
  ring.
Qed.

Lemma f_sin_cos_body_correct' :
  { f_sin_error : _ &
                        { f_cos_error |
                          forall
 (ge: Clight.genv)
      b_sin fn_sin
      (Hb_sin: Globalenvs.Genv.find_symbol ge _sin = Some b_sin)
      (Hfn_sin: Globalenvs.Genv.find_funct_ptr ge b_sin = Some fn_sin)
      (Hfn_sin_correct: SARBackProjSourceSin.f_unary_correct sin ge fn_sin)
      b_cos fn_cos
      (Hb_cos: Globalenvs.Genv.find_symbol ge _cos = Some b_cos)
      (Hfn_cos: Globalenvs.Genv.find_funct_ptr ge b_cos = Some fn_cos)
      (Hfn_cos_correct: SARBackProjSourceSin.f_unary_correct cos ge fn_cos)
,
  f_sin_cos_correct f_sin_error f_cos_error ge (Clight.Internal (f_sin_cos))
}}.
Proof.
  esplit. esplit.

  split; auto.
  intros os Hos_align oc Hoc_align ps Hps pc Hpc bs bc m P Hm x Hx_finite Hx_range st0.
  unfold x_left, x_right in Hx_range.
  unfold st0.
  clear st0.

  apply f_sin_correct in Hfn_sin_correct.
  destruct Hfn_sin_correct as (sin_type & Hfn_sin_correct).
  apply f_cos_correct in Hfn_cos_correct.
  destruct Hfn_cos_correct as (cos_type & Hfn_cos_correct).

  unfold f_unary_error in Hfn_sin_correct, Hfn_cos_correct.

  match goal with
    |- exists m', Smallstep.star step2 ?ge ?s Events.E0 (Returnstate Vundef Kstop m') /\ ?P =>
    cut
      (exists s',
         Smallstep.star step2 ge s Events.E0 s' /\
         exists m',
           s' = Returnstate Vundef Kstop m' /\
           P)
  end.
  {
    intro H;  break H; subst; eauto 13.
  }
  apply star_exists_step.
  call_fn.
  simpl fn_body.

  repeat run.

  apply exec_call_exists.
  solve_trivial.
  eapply exists_modus_ponens.
  {
    eapply exists_double_elim.
    eapply Hfn_sin_correct; eauto.
  }
  intros s1 Hs1.
  simpl in Hs1.
  destruct Hs1 as (si & ? & Hsi_finite & Hsi_val & Hsi_range).
  subst s1.
  solve_trivial.
  repeat run.

  apply eval_expr_exists_filter_float.
  apply Vsingle_exists.
  (* here comes the framework into play! *)
  C_to_float_as sif Hsif.
  compute_fval_as Hsif Hsif_finite Hsif_val.
  solve_trivial.

  repeat run.

  holds_storev_solve.
  intros m Hm.
  repeat run.

  apply exec_call_exists.
  solve_trivial.
  eapply exists_modus_ponens.
  {
    eapply exists_double_elim.
    eapply Hfn_cos_correct; eauto.
  }
  intros s1 Hs1.
  simpl in Hs1.
  destruct Hs1 as (co & ? & Hco_finite & Hco_val & Hco_range).
  subst s1.
  solve_trivial.
  repeat run.

  apply eval_expr_exists_filter_float.
  apply Vsingle_exists.
  (* here comes the framework into play! *)
  C_to_float_as cof Hcof.
  compute_fval_as Hcof Hcof_finite Hcof_val.
  solve_trivial.

  repeat run.

  holds_storev_solve.
  intros m Hm.
  repeat run.

  apply star_exists_refl.
  solve_trivial.

  exists sif, cof.
  split.
  {
    revert Hm.
    apply holds_list_comm_aux.
    apply count_occ_list_comm.
    intros; repeat rewrite count_occ_app; omega.
  }

  split; auto.

  split.
  {
    symmetry in Hsif_val.
    rewrite Rmult_1_l in *.
    apply round_to_error in Hsif_val.
    match type of Hsif_val with
        _ = ?z =>
        interval_intro (Rabs z) upper with (i_prec 128) as Hsif_error
    end.
    rewrite <- Hsif_val in Hsif_error.
    eapply Rabs_triang2.
    {
      eassumption.
    }
    eassumption.
  }
  symmetry in Hcof_val.
  rewrite Rmult_1_l in *.
  apply round_to_error in Hcof_val.
  match type of Hcof_val with
      _ = ?z =>
      interval_intro (Rabs z) upper with (i_prec 128) as Hcof_error
  end.
  rewrite <- Hcof_val in Hcof_error.
  eapply Rabs_triang2.
  {
    eassumption.
  }
  eassumption.
Defined.

Definition f_sin_error' :=
  let (x, _) := f_sin_cos_body_correct' in x.

Definition f_sin_error'_eq :=
  $( field_eq f_sin_error' )$ .

Definition f_sin_error :=
  $(
      match type of f_sin_error'_eq with
        _ = ?z => exact z
      end
    )$ .

Definition f_cos_error' :=
  let (_, y) := f_sin_cos_body_correct' in
  let (x, _) := y in x.

Definition f_cos_error'_eq :=
  $( field_eq f_cos_error' )$ .

Definition f_cos_error :=
  $(
      match type of f_cos_error'_eq with
        _ = ?z => exact z
      end
    )$ .

Lemma f_sin_cos_error_correct:
                          forall
 (ge: Clight.genv)
      b_sin fn_sin
      (Hb_sin: Globalenvs.Genv.find_symbol ge _sin = Some b_sin)
      (Hfn_sin: Globalenvs.Genv.find_funct_ptr ge b_sin = Some fn_sin)
      (Hfn_sin_correct: SARBackProjSourceSin.f_unary_correct sin ge fn_sin)
      b_cos fn_cos
      (Hb_cos: Globalenvs.Genv.find_symbol ge _cos = Some b_cos)
      (Hfn_cos: Globalenvs.Genv.find_funct_ptr ge b_cos = Some fn_cos)
      (Hfn_cos_correct: SARBackProjSourceSin.f_unary_correct cos ge fn_cos)
,
  f_sin_cos_correct f_sin_error f_cos_error ge (Clight.Internal (f_sin_cos))
.
Proof.
  unfold f_sin_error.
  rewrite <- f_sin_error'_eq.
  unfold f_cos_error.
  rewrite <- f_cos_error'_eq.
  unfold f_sin_error', f_cos_error'.
  destruct f_sin_cos_body_correct'.
  destruct s.
  assumption.
Qed.


Require Import VST.floyd.proofauto.
Require Import pile.
Require Import spec_stdlib.
Require Import PileModel.

Record PileAPD := {
  pilerep: list Z -> val -> mpred;
  pilerep_local_facts: forall sigma p,
    pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma);
  pilerep_valid_pointer: forall sigma p,
    pilerep sigma p |-- valid_pointer p;
  pile_freeable (p: val) : mpred (* Definitely don't expose the definition of this as malloc_token, because that would expose the fact that there's exactly one malloc'ed record in the implementation. *)
}.

#[export] Hint Resolve pilerep_local_facts : saturate_local.
#[export] Hint Resolve pilerep_valid_pointer : valid_pointer.

Definition tpile := Tstruct _pile noattr.

Local Open Scope assert.

Section PileASI.
Variable M: MallocFreeAPD.
Variable PILE:PileAPD.

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS() GLOBALS(gv) SEP(mem_mgr M gv)
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(pilerep PILE nil p; pile_freeable PILE p; mem_mgr M gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(pilerep PILE sigma p; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep PILE (n::sigma) p; mem_mgr M gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS (p) GLOBALS ()
    SEP (pilerep PILE sigma p)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep PILE sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) (GLOBALS (gv)
    SEP(pilerep PILE sigma p; pile_freeable PILE p; mem_mgr M gv))
 POST[ tvoid ]
     PROP() LOCAL() SEP(mem_mgr M gv).

Definition PileASI:funspecs := [ Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].

End PileASI.