(* Continuation-Passing Style language for the CertiCoq project.
 *   Initial design, Andrew W. Appel, June 2014
 *)
From Coq Require Import ZArith.ZArith Lists.List.
From CertiCoq.Common Require Import AstCommon.
From CertiCoq.LambdaANF Require Import List_util map_util.
From compcert.lib Require Export  Maps.
From CertiCoq.LambdaANF Require Export map_util.
From MetaCoq.Template Require Import BasicAst. (* For identifier names *)

Import ListNotations.

(* We will use several maps from identifiers to types, values, etc.
 * For now we'll use Xavier Leroy's efficient polymorphic maps from
 * positive numbers to _. When the MMaps module of the Coq stdlib is
 * created, we'll use that. *)

Module M := Maps.PTree.

Definition var      := M.elt. (* value variables *)
Definition fun_tag  := M.elt. (* discrimination tags for functions *)
Definition ind_tag  := M.elt. (* discrimination tags for inductive types *)
Definition ctor_tag := M.elt. (* discrimination tags for constructors *)
Definition prim     := M.elt. (* primitive operators *)

(* Remark.  It sure would be nice if we could use abstraction here,
   so that M was instantiated differently for vars, types, and tags,
   such that [var] was not beta-eta equal to [type].  But then the
   type of maps [M.t] would have to be abstract, and that in turn
   would mean that Coq could not determine that [M.t(A)] is covariant
   in A.  Which, in turn, would make impossible the inductive definition
   of [val], below.
 *)

(* To describe the [i]th field of a record, we use type BinNat,
   that is, [N].  This has a more efficient representation than [nat],
   which is a consideration for programs that process large
   abstract syntax trees.
 *)

(* Given a list of tagged variants, return the one with the matching tag. *)
Fixpoint findtag {A} (cl: list (ctor_tag * A)) (c: ctor_tag) : option A :=
  match cl with
  | (c',a)::cl' => if M.elt_eq c' c then Some a else findtag cl' c
  | nil => None
  end.

(** * LambdaANF Expressions *)

(* Expressions [exp] of the LambdaANF language. *)
Inductive exp : Type :=
| Econstr: var -> ctor_tag -> list var -> exp -> exp
| Ecase: var -> list (ctor_tag * exp) -> exp
| Eproj: var -> ctor_tag -> N -> var -> exp -> exp
| Eletapp: var -> var -> fun_tag -> list var -> exp -> exp
| Efun: fundefs -> exp -> exp
| Eapp: var -> fun_tag -> list var -> exp
| Eprim_val : var -> primitive -> exp -> exp
| Eprim: var -> prim -> list var -> exp -> exp (* where prim is id *)
| Ehalt : var -> exp
with fundefs : Type :=
| Fcons: var -> fun_tag -> list var -> exp -> fundefs -> fundefs
| Fnil: fundefs.

(* [Econstr x t c ys e] applies a data constructor with tag [c] to
           a list of values denoted by variables [ys].   The resulting
           value is bound to variable [x] of type [t], and then execution
           continues with expression [e].  Static typing requires that
           the typeinfo bound to [t] has a variant consistent with [c]
           and the types of [ys].
   [Ecase v cl] does case-discrimination on value [v], which
          must be a [Vconstr t c vs] value. One of the elements of
          [cl] must be the pair [(c,e)], where [e] a expression
          that uses [v] (and makes necessary projections).
   [Eproj v t n y e] projects the record value [y] by selecting
          the [n]th element of the record.   This is bound to [v] of type [t]
          and execution continues with [e].  Typechecking requires
          that the type of [y] be a Tdata with a single variant, whose
          data list has length at least n.
   [Efun x f ft ys e] applies the function f to arguments ys and binds the result
         to x in e.
   [Efun fl e]  binds the set of mutually recursive functions [fl]
          into the environment, and continues with [e].
   [Eapp f ys]   applies the function [f] to arguments [ys]
   [Eprim x t f ys e] applies primop [f] to arguments [ys]
          and binds the result to [x] of type [t], continues with [e].
          The primop [f] is a primitive operator, whose type is equivalent to
          the CPS transform of [ts->t], where [ts] are the type of the [ys].

   [Fdef f t ys e]   defines a function [f] of type [t] with parameters [ys]
          and body [e].  We do not syntactically distinguish continuations
          from other functions, as Andrew Kennedy does [Compiling with
          Continuations, Continued, 2007].  Instead, we rely on the type
          system to do it; see below.  This mechanism also permits
          classifying functions into different calling conventions, even
          if they have the same source-language type.
*)

(* Remark.  It is conventional in LambdaANF representations to guarantee
   that no two binding occurrences bind the same variable-name.
   However, neither the static (typing) semantics nor the dynamic
   (small-step) semantics requires this.  Some of the transformation
   (optimization, rewrite) algorithms may require it.
*)

(** Induction principles for exp anf fundefs *)

Lemma exp_ind' :
  forall P : exp -> Type,
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall (f2 : fundefs) (e : exp), P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var)  (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    forall e : exp, P e.
Proof.
  intros P H1 H2 H3 H4 H5 H6 H7 H8 H9 H10. fix exp_ind' 1.
  destruct e; try (now clear exp_ind'; eauto).
  - eapply H1. eapply exp_ind'; eauto.
  - induction l as [ | [c e] xs IHxs].
    + eapply H2.
    + eapply H3. apply exp_ind'. eauto.
  - eapply H4. eapply exp_ind'; eauto.
  - eapply H5. eapply exp_ind'; eauto.
  - eapply H6. eapply exp_ind'; eauto.
  - eapply H8. eapply exp_ind'; eauto.
  - eapply H9. eapply exp_ind'; eauto.
Qed.

(** Mutual induction scheme for exp and fundefs *)
Lemma exp_mut :
  forall (P : exp -> Type) (P0 : fundefs -> Type),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall e : exp, P e
with fundefs_mut :
  forall (P : exp -> Type) (P0 : fundefs -> Type),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall f7 : fundefs, P0 f7.
Proof.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.
    destruct e; eauto.
    + eapply H1. eapply exp_mut; eauto.
    + induction l as [ | [c e] xs IHxs].
      * eapply H2.
      * eapply H3; eauto. eapply exp_mut; eauto.
    + eapply H4. eapply exp_mut; eauto.
    + eapply H5. eapply exp_mut; eauto.
    + eapply H6. eapply fundefs_mut; eauto.
      eapply exp_mut; eauto.
    + eapply H8. eapply exp_mut; eauto.
    + eapply H9. eapply exp_mut; eauto.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 defs.
    destruct defs; eauto.
    eapply H11. eapply exp_mut; eauto.
    eapply fundefs_mut; eauto.
Qed.

Lemma exp_mut_alt :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var) (l : list (ctor_tag * exp)),
       Forall (fun x => P (snd x)) l -> P (Ecase v l)) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall e : exp, P e
with fundefs_mut_alt :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var) (l : list (ctor_tag * exp)),
        Forall (fun x => P (snd x)) l -> P (Ecase v l)) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall f7 : fundefs, P0 f7.
Proof.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11.
    destruct e; eauto.
    + eapply H1. eapply exp_mut_alt; eauto.
    + eapply H2. induction l as [ | [c e] xs IHxs].
      now constructor.
      constructor; [| eassumption ]. eapply exp_mut_alt; eauto.
    + eapply H3. eapply exp_mut_alt; eauto.
    + eapply H4. eapply exp_mut_alt; eauto.
    + eapply H5. eapply fundefs_mut_alt; eauto.
      eapply exp_mut_alt; eauto.
    + eapply H7. eapply exp_mut_alt; eauto.
    + eapply H8. eapply exp_mut_alt; eauto.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 defs.
    destruct defs; eauto.
    eapply H10. eapply exp_mut_alt; eauto.
    eapply fundefs_mut_alt; eauto.
Qed.

(* to do proofs simultaneously. *)
Lemma exp_def_mutual_ind :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> (forall e : exp, P e) /\ (forall f : fundefs, P0 f).
Proof.
  intros. split.
  apply (exp_mut P P0); assumption.
  apply (fundefs_mut P P0); assumption.
Qed.

Lemma exp_def_mutual_ind' :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var) (l : list (ctor_tag * exp)),
        Forall (fun x => P (snd x)) l -> P (Ecase v l)) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> (forall e : exp, P e) /\ (forall f : fundefs, P0 f).
Proof.
  intros. split.
  apply (exp_mut_alt P P0); assumption.
  apply (fundefs_mut_alt P P0); assumption.
Qed.

(** name the induction hypotheses only *)
Ltac exp_defs_induction IH1 IHl IH2 :=
  apply exp_def_mutual_ind;
  [ intros ? ? ? ? IH1
  | intros ?
  | intros ? ? ? ? IH1 IHl
  | intros ? ? ? ? ? IH1
  | intros ? ? ? ? ? IH1
  | intros ? IH2 ? IH1
  | intros ? ? ?
  | intros ? ? ? IH1
  | intros ? ? ? ? IH1
  | intros ?
  | intros ? ? ? ? IH1 ? IH2
  | ].

(** * CPS Values *)

Inductive val : Type :=
| Vconstr : ctor_tag -> list val -> val
| Vfun : M.t val -> fundefs -> var -> val
(* [Vfun env fds f]
     where env is the environment at the function binding site
     fds is the list of mutually recursive functions including f *)
| Vprim : primitive -> val
| Vint : Z -> val.

(** Induction principle for values. *)
Lemma val_ind' :
  forall P : val -> Prop,
    (forall (t : ctor_tag), P (Vconstr t nil)) ->
    (forall (t : ctor_tag) (v : val) (l : list val),
        P v -> P (Vconstr t l) -> P (Vconstr t (v :: l))) ->
    (forall (t : M.t val) (f0 : fundefs) (v : var), P (Vfun t f0 v)) ->
    (forall p, P (Vprim p)) ->
    (forall z : Z, P (Vint z)) ->
    forall v : val, P v.
Proof.
  intros P H1 H2 H3 H4 H5.
  fix val_ind' 1.
  destruct v; try (now clear val_ind'; eauto).
  - induction l as [ | x xs IHxs].
    eapply H1. eapply H2. apply val_ind'. eauto.
Qed.

Fixpoint def_funs (fl0 fl: fundefs) (rho0 rho: M.t val) : M.t val :=
  match fl with
  | Fcons f t xs e fl' => M.set f (Vfun rho0 fl0 f) (def_funs fl0 fl' rho0 rho)
  | Fnil => rho
  end.

Fixpoint find_def (f: var) (fl:  fundefs) :=
  match fl with
  | Fcons f' t ys e fl' => if M.elt_eq f f' then Some (t,ys,e)
                           else find_def f fl'
  | Fnil => None
  end.

(** * Information associated with identifiers **)

(* The info of a constructor. *)
Record ctor_ty_info : Set :=
  Build_ctor_ty_info
    { ctor_name     : name    (* the name of the constructor *)
    ; ctor_ind_name : name    (* the name of its inductive type *)
    ; ctor_ind_tag  : ind_tag (* ind_tag of corresponding inductive type *)
    ; ctor_arity    : N       (* the arity of the constructor *)
    ; ctor_ordinal  : N       (* the [ctor_tag]s ordinal in inductive defn starting at zero *)
    }.

(* The info of an inductive type is list of the ctags of its constructors *)
Definition ind_ty_info : Set := list (ctor_tag * N).

Definition unknown_ctor_ty_info : ctor_ty_info :=
  {| ctor_name     := nAnon
   ; ctor_ind_name := nAnon
   ; ctor_ind_tag  := 1%positive
   ; ctor_arity    := 0%N
   ; ctor_ordinal  := 0%N
  |}.

Definition unknown_ind_ty_info : ind_ty_info := nil.

(* An constructor environment maps [ctor_tag]s to their information *)
Definition ctor_env : Set := M.tree ctor_ty_info.

(* An inductive type environment maps [ind_tag]s to their constructors with their arities *)
Definition ind_env : Set := M.tree ind_ty_info.

(* Every calling convention requires knowing
   how many arguments in which slots of the arg array *)
Definition fun_ty_info : Set := N * list N.

Definition fun_env : Set := M.tree fun_ty_info.

(** Register the tag used for closures **)
Definition add_closure_tag (c i : positive) (cenv : ctor_env) : ctor_env :=
  let info := {| ctor_name     := nAnon
               ; ctor_ind_name := nAnon
               ; ctor_ind_tag  := i
               ; ctor_arity    := 2%N
               ; ctor_ordinal  := 0%N
              |}
  in M.set c info cenv.


From refinedc.typing Require Import typing.
From refinedc.project.learning.src.circuit Require Import generated_code.
From refinedc.project.learning.src.circuit Require Import generated_spec.
Set Default Proof Using "Type".

(* Generated from [src/circuit.c]. *)
Section proof_set_one.
  Context `{!typeG Σ} `{!globalG Σ}.

  (* Typing proof for [set_one]. *)
  Lemma type_set_one :
    ⊢ typed_function impl_set_one type_of_set_one.
  Proof.
    Open Scope printing_sugar.
    start_function "set_one" ([[[a b] x] p]) => arg_c arg_v.
    prepare_parameters (a b x p).
    split_blocks ((
      ∅
    )%I : gmap label (iProp Σ)) ((
      ∅
    )%I : gmap label (iProp Σ)).
    - repeat liRStep; liShow.
      all: print_typesystem_goal "set_one" "#0".
    Unshelve. all: li_unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
    all: print_sidecondition_goal "set_one".
    Unshelve. all: try done; try apply: inhabitant; print_remaining_shelved_goal "set_one".
  Qed.
End proof_set_one.


Require Import Category.Lib.
Require Import Category.Instance.Lambda.Ltac.
Require Import Category.Instance.Lambda.Ty.
Require Import Category.Instance.Lambda.Exp.
Require Import Category.Instance.Lambda.Value.
Require Import Category.Instance.Lambda.Ren.
Require Import Category.Instance.Lambda.Sub.
Require Import Category.Instance.Lambda.Log.
Require Import Category.Instance.Lambda.Sem.
Require Import Category.Instance.Lambda.Multi.
Require Import Category.Instance.Lambda.Sound.
Require Import Category.Instance.Lambda.Step.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

Section Norm.

#[local] Hint Constructors ValueP Step : core.

#[local] Hint Extern 7 (_ ---> _) => repeat econstructor : core.

Definition normalizing `(R : crelation X) : Type :=
  ∀ t, ∃ t', multi R t t' ∧ normal_form R t'.

Definition halts {Γ τ} (e : Exp Γ τ) : Type :=
  ∃ e', e --->* e' ∧ ValueP e'.

Notation " e '⇓' " := (halts e) (at level 11).

Definition normal_form_of {Γ τ} (e e' : Exp Γ τ) : Type :=
  (e --->* e' ∧ normal_form Step e').

Ltac normality :=
  exfalso;
  lazymatch goal with
    | [ H1 : ValueP ?X, H2 : ?X ---> ?Y |- False ] =>
        apply value_is_nf in H1; destruct H1;
        now exists Y
    | [ H1 : normal_form ?R ?X, H2 : ?R ?X ?Y |- False ] =>
        exfalso; now apply (H1 Y)
  end.

Ltac invert_step :=
  try lazymatch goal with
  | [ H : _ ---> _ |- _ ] => now inv H
  end;
  try solve [ f_equal; intuition eauto | normality ].

Lemma value_halts {Γ τ} (v : Exp Γ τ) : ValueP v → halts v.
Proof.
  intros X.
  unfold halts.
  now induction X; eexists; repeat constructor.
Qed.

Theorem normal_forms_unique Γ τ :
  deterministic (normal_form_of (Γ:=Γ) (τ:=τ)).
Proof.
  unfold deterministic, normal_form_of.
  intros x y1 y2 P1 P2.
  destruct P1 as [P11 P12].
  destruct P2 as [P21 P22].
  generalize dependent y2.
  induction P11; intros.
  - inversion P21; auto.
    now einduction P12; eauto.
  - apply IHP11; auto.
    inv P21.
    + now edestruct P22; eauto.
    + assert (y = y0) by now apply Step_deterministic with x.
      now subst.
Qed.

Lemma step_preserves_halting {Γ τ} (e e' : Exp Γ τ) :
  (e ---> e') → (halts e ↔ halts e').
Proof.
  intros.
  unfold halts.
  split.
  - intros [e'' [H1 H2]].
    + destruct H1.
      * apply value_is_nf in H2.
        now edestruct H2; eauto.
      * rewrite (Step_deterministic _ _ _ _ _ H s).
        now intuition eauto.
  - intros [e'0 [H1 H2]].
    + exists e'0.
      split; auto.
      now eapply multi_step; eauto.
Qed.

Definition SN {Γ τ} : Γ ⊢ τ → Type := ExpP (@halts Γ).
Arguments SN {Γ τ} _ /.

Definition SN_Sub {Γ Γ'} : Sub Γ' Γ → Type := SubP (@halts Γ').
Arguments SN_Sub {Γ Γ'} /.

Definition SN_halts {Γ τ} {e : Γ ⊢ τ} : SN e → halts e := ExpP_P _.

#[local] Transparent ExpP.

Lemma step_preserves_SN {Γ τ} {e e' : Γ ⊢ τ} :
  (e ---> e') → SN e → SN e'.
Proof.
  intros.
  induction τ; simpl in *;
  pose proof H as H2;
  apply step_preserves_halting in H2;
  firstorder.
Qed.

Lemma multistep_preserves_SN {Γ τ} {e e' : Γ ⊢ τ} :
  (e --->* e') → SN e → SN e'.
Proof.
  intros.
  induction X; auto.
  apply IHX.
  now eapply step_preserves_SN; eauto.
Qed.

Lemma step_preserves_SN' {Γ τ} {e e' : Γ ⊢ τ} :
  (e ---> e') → SN e' → SN e.
Proof.
  intros.
  induction τ; simpl in *;
  pose proof H as H2;
  apply step_preserves_halting in H2;
  firstorder.
Qed.

Lemma multistep_preserves_SN' {Γ τ} {e e' : Γ ⊢ τ} :
  (e --->* e') → SN e' → SN e.
Proof.
  intros.
  induction X; auto.
  now eapply step_preserves_SN'; eauto.
Qed.

Lemma SubExp_SN {Γ Γ'} (env : Sub Γ' Γ) {τ} (e : Exp Γ τ) :
  SN_Sub env →
  SN (SubExp env e).
Proof.
  generalize dependent env.
  induction e; intros; simpl.
  - now eexists; repeat constructor.
  - split.
    + destruct (SN_halts (IHe1 env X)) as [v1 [P1 Q1]].
      destruct (SN_halts (IHe2 env X)) as [v2 [P2 Q2]].
      exists (Pair v1 v2).
      split.
      * now apply multistep_Pair.
      * now repeat constructor.
    + split.
      * destruct (SN_halts (IHe1 env X)) as [v1 [P1 Q1]].
        destruct (SN_halts (IHe2 env X)) as [v2 [P2 Q2]].
        apply (multistep_preserves_SN' (e':=v1)); auto.
        ** rewrite (multistep_Fst1 (p':=Pair v1 v2)).
           *** now apply multi_R; eauto.
           *** erewrite multistep_Pair1; eauto.
               erewrite multistep_Pair2; eauto.
               now apply multi_refl.
        ** apply (multistep_preserves_SN (e:=SubExp env e1));
           now intuition.
      * destruct (SN_halts (IHe1 env X)) as [v1 [P1 Q1]].
        destruct (SN_halts (IHe2 env X)) as [v2 [P2 Q2]].
        apply (multistep_preserves_SN' (e':=v2)); auto.
        ** rewrite (multistep_Snd1 (p':=Pair v1 v2)).
           *** now apply multi_R; eauto.
           *** erewrite multistep_Pair1; eauto.
               erewrite multistep_Pair2; eauto.
               now apply multi_refl.
        ** apply (multistep_preserves_SN (e:=SubExp env e2));
           now intuition.
  - now apply IHe.
  - now apply IHe.
  - induction env.
    + now inv v.
    + dependent elimination X.
      now dependent elimination v; simpl in *; simp SubVar.
  - split.
    + now eexists; repeat constructor.
    + intros.
      destruct (SN_halts X0) as [v [P Q]].
      apply (multistep_preserves_SN' (e':=SubExp (Push v env) e)); auto.
      * eapply multi_trans; eauto.
        ** now eapply multistep_AppR; eauto.
        ** apply multi_R; auto.
           now rewrite SubExp_Push; eauto 6.
      * apply IHe.
        constructor; auto.
        now eapply multistep_preserves_SN; eauto.
  - now apply IHe1, IHe2.
Qed.

Theorem Exp_SN {τ} (e : Exp nil τ) : SN e.
Proof.
  intros.
  replace e with (SubExp (Γ:=nil) NoSub e).
  - apply SubExp_SN.
    now constructor.
  - now rewrite NoSub_idSub, SubExp_idSub.
Qed.

Corollary strong_normalization {τ} (e : Exp nil τ) : e ⇓.
Proof.
  pose proof (Exp_SN e) as X.
  now apply SN_halts.
Qed.

End Norm.


(** * Similar states after first rising edge  *)

Require Import sitpn.SitpnLib.

Require Import hvhdl.HVhdlCoreLib.
Require Import hvhdl.HVhdlElaborationLib.
Require Import hvhdl.HVhdlSimulationLib.
Require Import hvhdl.HVhdlHilecopLib.

Require Import transformation.Sitpn2HVhdl.

Require Import soundness.SemanticPreservationDefs.

Lemma first_rising_edge_full :
  forall sitpn b d γ E__c E__p Δ σ__e σ0 τ σ__r σ,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    (* From [σ0] to [σ] after [↑]. *)
    VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r ->
    Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ ->

    (* States [s] and [σ] are similar. *)
    FullSimStateAfterRE sitpn γ E__c τ (s0 sitpn) σ.
Admitted.

(* Tries to apply the [first_rising_edge_full] lemma when the goal is of the form
   [SimStateAfterFE _ _ _ _] or [_ ⊢ _ ∼ _]. *)
#[export] Hint Resolve first_rising_edge_full : hilecop.
#[export] Hint Extern 1 ( _ ⊢ _ ∼ _ ) => eapply first_rising_edge_full; eauto : hilecop.

Lemma first_rising_edge :
  forall sitpn b d γ E__c E__p Δ σ__e σ0 τ σ__r σ,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    (* From [σ0] to [σ] after [↑]. *)
    VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r ->
    Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ ->

    (* States [s] and [σ] are similar. *)
    SimStateAfterRE sitpn γ (s0 sitpn) σ.
Proof. eapply first_rising_edge_full; eauto. Qed.

(* Tries to apply the [first_rising_edge] lemma when the goal is of the form
   [SimStateAfterFE _ _ _ _] or [_ ⊢ _ ∼ _]. *)
#[export] Hint Resolve first_rising_edge : hilecop.
#[export] Hint Extern 1 ( _ ⊢ _ ∼ _ ) => eapply first_rising_edge; eauto : hilecop.

(** States that, for all SITPN [sitpn] passed as input to the HM2T and
    resulting design [d], if [σ0] is the initial state of [d] then a
    rising edge phase can be computed from [σ0], and thus ends in
    state [σ], such that [σ] is similar to the initial state [s0] of
    [sitpn]. *)

Lemma first_rising_edge_lock_step_full :
  forall sitpn b d γ E__c E__p Δ σ__e σ0,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    forall τ,
    exists σ__r σ,
      (* From [σ0] to [σ] after [↑]. *)
      VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r
      /\ Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ

      (* States [s] and [σ] are "fully" similar. *)
      /\ FullSimStateAfterRE sitpn γ E__c τ (s0 sitpn) σ.
Admitted.

#[export] Hint Resolve first_rising_edge_lock_step_full : hilecop.

Lemma first_rising_edge_lock_step :
  forall sitpn b d γ E__c E__p Δ σ__e σ0,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    forall τ,
    exists σ__r σ,
      (* From [σ0] to [σ] after [↑]. *)
      VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r
      /\ Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ

      (* States [s] and [σ] are similar. *)
      /\ SimStateAfterRE sitpn γ (s0 sitpn) σ.
Proof.
  intros until τ.
  edestruct first_rising_edge_lock_step_full as (σ__r, (σ, (HVConc, (Hstab, Hfsim)))); eauto.
  exists σ__r, σ; eauto with hilecop.
Qed.

#[export] Hint Resolve first_rising_edge_lock_step : hilecop.


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.