Require Import AutoSep Util.
Require Import Arith List.

Set Implicit Arguments.

Local Hint Extern 1 (himp _ (allocated _ _ _) (allocated _ _ _)) => apply allocated_shift_base.

(** * A free-list heap managed by the malloc library *)

Definition noWrapAround (p : W) (sz : nat) :=
  forall n, (n < 4 * sz)%nat -> p ^+ $(n) <> $0.

Definition freeable (p : W) (sz : nat) := (sz >= 2)%nat
  /\ noWrapAround p sz.

Lemma BigEnough : forall p sz, freeable p sz -> (sz >= 2)%nat.
  unfold freeable; tauto.
Qed.

Lemma SmallEnough : forall p sz, freeable p sz -> noWrapAround p sz.
  unfold freeable; tauto.
Qed.

Local Hint Immediate BigEnough SmallEnough.
Local Hint Unfold freeable.

Module Type FREE_LIST.
  Parameter freeList : nat (* number of elements in list *) -> W -> HProp.
  Parameter mallocHeap : W -> HProp.

  Axiom freeList_extensional : forall n p, HProp_extensional (freeList n p).
  Axiom mallocHeap_extensional : forall p, HProp_extensional (mallocHeap p).

  Axiom mallocHeap_fwd : forall p, mallocHeap p ===> Ex n, Ex p', p =*> p' * freeList n p'.
  Axiom mallocHeap_bwd : forall p, (Ex n, Ex p', p =*> p' * freeList n p') ===> mallocHeap p.

  Axiom nil_bwd : forall n p, p = 0 -> [| n = 0 |] ===> freeList n p.
  Axiom cons_bwd : forall n (p : W), p <> 0
    -> (Ex n', Ex sz, Ex p', [| n = S n' |]
      * [| noWrapAround p (2 + wordToNat sz) |]
      * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p')
    ===> freeList n p.

  Axiom cons_fwd : forall n (p : W), p <> 0
    -> freeList n p
    ===> Ex n', Ex sz, Ex p', [| n = S n' |]
    * [| noWrapAround p (2 + wordToNat sz) |]
    * (p ==*> sz, p')  * (p ^+ $8) =?> wordToNat sz * freeList n' p'.
End FREE_LIST.

Module FreeList : FREE_LIST.
  Open Scope Sep_scope.

  Fixpoint freeList (n : nat) (p : W) : HProp :=
    match n with
      | O => [| p = 0 |]
      | S n' => [| p <> 0 |] * Ex sz, Ex p',
        [| noWrapAround p (2 + wordToNat sz) |]
        * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p'
    end.

  Definition mallocHeap (p : W) := Ex n, Ex p', p =*> p' * freeList n p'.

  Theorem freeList_extensional : forall n p, HProp_extensional (freeList n p).
    destruct n; reflexivity.
  Qed.

  Theorem mallocHeap_extensional : forall p, HProp_extensional (mallocHeap p).
    reflexivity.
  Qed.

  Theorem mallocHeap_fwd : forall p, mallocHeap p ===> Ex n, Ex p', p =*> p' * freeList n p'.
    unfold mallocHeap; sepLemma.
  Qed.

  Theorem mallocHeap_bwd : forall p, (Ex n, Ex p', p =*> p' * freeList n p') ===> mallocHeap p.
    unfold mallocHeap; sepLemma.
  Qed.

  Theorem nil_bwd : forall n p, p = 0 -> [| n = 0 |] ===> freeList n p.
    destruct n; sepLemma.
  Qed.

  Theorem cons_bwd : forall n (p : W), p <> 0
    -> (Ex n', Ex sz, Ex p', [| n = S n' |]
      * [| noWrapAround p (2 + wordToNat sz) |]
      * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p')
    ===> freeList n p.
    destruct n; sepLemma; match goal with
                            | [ H : S _ = S _ |- _ ] => injection H
                          end; sepLemma.
  Qed.

  Theorem cons_fwd : forall n (p : W), p <> 0
    -> freeList n p
    ===> Ex n', Ex sz, Ex p', [| n = S n' |]
    * [| noWrapAround p (2 + wordToNat sz) |]
    * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p'.
    destruct n; sepLemma.
  Qed.
End FreeList.

Import FreeList.
Export FreeList.
Hint Immediate freeList_extensional mallocHeap_extensional.

Ltac expose := intros w ?; case_eq (wordToNat w); [ intro Heq;
  apply (f_equal (natToWord 32)) in Heq; rewrite natToWord_wordToNat in Heq;
    subst; elimtype False; auto
  | intros n Heq; repeat (destruct n; [
    apply (f_equal (natToWord 32)) in Heq; rewrite natToWord_wordToNat in Heq;
      subst; elimtype False; auto
    | eauto ]) ].

Lemma expose2N : forall n,
  (n >= 2)%nat
  -> exists n', n = S (S n').
  destruct n as [ | [ | ] ]; eauto; intros; omega.
Qed.

Lemma expose2' : forall w : W,
  $2 <= w
  -> exists n', wordToNat w = S (S n').
  expose.
Qed.

Lemma expose3' : forall (w : W),
  w >= $3
  -> exists n, wordToNat w = S (S (S n)).
  expose.
Qed.

Inductive fwd : Prop := Fwd.
Inductive bwd : Prop := Bwd.
Hint Constructors fwd bwd.

Lemma freeable_fwd : forall p sz,
  freeable p sz
  -> fwd
  -> p =?> sz ===> Ex u, Ex v, p =*> u * (p ^+ $4) =*> v * (p ^+ $8) =?> (sz-2).
  intuition idtac; destruct (expose2N (BigEnough H)) as [? Heq];
    rewrite Heq; sepLemma; apply allocated_shift_base; omega || words.
Qed.

Lemma expose2_bwd : forall p (sz : W),
  $2 <= sz
  -> bwd
  -> (Ex u, Ex v, p =*> u * (p ^+ $4) =*> v * (p ^+ $8) =?> (wordToNat sz-2)) ===> p =?> wordToNat sz.
  intros; destruct (expose2' H) as [? Heq];
    rewrite Heq; sepLemma; apply allocated_shift_base; omega || words.
Qed.

Lemma expose3_fwd : forall p (sz : W),
  sz >= $3
  -> p =?> wordToNat sz ===> Ex u, Ex v, Ex w, p =*> u * (p ^+ $4) =*> v * (p ^+ $8) =*> w * (p ^+ $12) =?> (wordToNat sz-3).
  intros; destruct (expose3' H) as [? Heq]; rewrite Heq; sepLemma;
    apply allocated_shift_base; omega || words.
Qed.

Definition hints : TacPackage.
  prepare (mallocHeap_fwd, cons_fwd, freeable_fwd, expose3_fwd)
  (mallocHeap_bwd, nil_bwd, cons_bwd, expose2_bwd).
Defined.

Definition initS : spec := SPEC("base", "size") reserving 0
  PRE[V] [| $3 <= V "size" |]
    * [| noWrapAround (V "base" ^+ $4) (wordToNat (V "size") - 1) |]
    * V "base" =?> wordToNat (V "size")
  POST[_] mallocHeap (V "base").

Definition freeS : spec := SPEC("base", "p", "n") reserving 1
  PRE[V] [| V "p" <> 0 |] * [| freeable (V "p") (wordToNat (V "n")) |]
    * V "p" =?> wordToNat (V "n") * mallocHeap (V "base")
  POST[_] mallocHeap (V "base").

Definition mallocS : spec := SPEC("base", "n") reserving 4
  PRE[V] [| V "n" >= $2 |] * mallocHeap (V "base")
  POST[R] [| R <> 0 |] * [| freeable R (wordToNat (V "n")) |]
    * R =?> wordToNat (V "n") * mallocHeap (V "base").

Definition m := bmodule "malloc" {{
  bfunction "init"("base", "size") [initS]
    "base" *<- "base" + 4;;
    "base" + 4 *<- "size" - 3;;
    "base" + 8 *<- 0;;
    Return 0
  end with bfunction "free"("base", "p", "n", "tmp") [freeS]
    Note [fwd];;
    "p" *<- "n" - 2;;
    "tmp" <-* "base";;
    "base" *<- "p";;
    "p" + 4 *<- "tmp";;
    Return 0
  end with bfunction "malloc"("base", "n", "cur", "prev", "tmp", "tmp2") [mallocS]
    "cur" <-* "base";;
    "prev" <- "base";;

    [Al len,
      PRE[V] [| (V "n" >= $2)%word |] * V "prev" =*> V "cur" * freeList len (V "cur")
      POST[R] Ex p, Ex len', [| R <> 0 |] * [| freeable R (wordToNat (V "n")) |] * R =?> wordToNat (V "n")
        * V "prev" =*> p * freeList len' p]
    While ("cur" <> 0) {
      "tmp" <-* "cur";;
      "tmp" <- "tmp" + 2;;
      If ("tmp" = "n") {
        (* Exact size match on the current free list block *)
        Note [bwd];;

        "tmp" <-* "cur" + 4;;
        "prev" *<- "tmp";;
        Return "cur"
      } else {
        "tmp2" <-* "cur";;
        If ("n" < "tmp2") {
          (* This free list block is large enough to split in two. *)

          (* Calculate starting address of a suffix of this free block to return to caller. *)
          "tmp" <- "tmp2" - "n";;
          "tmp" <- "tmp" + 2;;
          "tmp" <- 4 * "tmp";;
          "tmp" <- "cur" + "tmp";;

          (* Decrement size of free list block to reflect deleted suffix. *)
          "tmp2" <- "tmp2" - "n";;
          "cur" *<- "tmp2";;

          (* Return suffix starting address. *)
          Return "tmp"
        } else {
          (* Current block too small; continue to next. *)
          "prev" <- "cur" + 4;;
          "cur" <-* "prev"
        }
      }
    };;

    Diverge (* out of memory! *)
  end
}}.

Local Hint Extern 1 (@eq (word _) _ _) => words.
Local Hint Extern 5 (@eq nat _ _) => omega.
Local Hint Extern 5 (_ <= _)%nat => omega.

Lemma three_le : forall w : W,
  $3 <= w
  -> (wordToNat w >= 3)%nat.
  intros; destruct (le_lt_dec (wordToNat w) 3); auto.
  pre_nomega.
  change (wordToNat (natToWord _ 3)) with 3 in H.
  omega.
Qed.

Lemma noWrapAround_plus4 : forall p (sz : W),
  noWrapAround p (wordToNat sz - 1)
  -> $3 <= sz
  -> p <> $0.
  intros.
  intro.
  eapply H.
  2: instantiate (1 := 0); words.
  apply three_le in H0.
  omega.
Qed.

Lemma noWrapAround_weaken : forall p sz p' sz',
  noWrapAround p sz
  -> (sz' <= sz)%nat
  -> p' = p ^+ $(4 * (sz - sz'))
  -> noWrapAround p' sz'.
  unfold noWrapAround; intros; subst.
  intro.
  rewrite <- wplus_assoc in H1.
  rewrite <- natToW_plus in H1.
  eapply H; [ | eassumption ].
  omega.
Qed.

Local Hint Extern 1 (noWrapAround _ _) =>
  eapply noWrapAround_weaken; [ eassumption | | ].

Lemma weq_cong : forall (w : W) n m,
  n = m
  -> w ^+ $(n) = w ^+ $(m).
  intros; subst; W_eq.
Qed.

Lemma weq_0 : forall (w w' : W) n,
  w = w'
  -> n = 0
  -> w = w' ^+ $(n).
  intros; subst; W_eq.
Qed.

Local Hint Resolve weq_0 weq_cong.

Lemma two_ge : forall w : W,
  (wordToNat w >= 2)%nat
  -> w >= $2.
  intros.
  intro.
  red in H0.
  pre_nomega.
  change (wordToNat (natToWord _ 2)) with 2 in *.
  omega.
Qed.

Lemma wminus0 : forall (w : W),
  (wordToNat w >= 2)%nat
  -> wordToNat (w ^- $2) = wordToNat w - 2.
  intros; rewrite wordToNat_wminus; auto.
  apply two_ge; auto.
Qed.

Hint Rewrite wminus0 using assumption : sepFormula.

Lemma sub2 : forall w w' : W,
  w' ^+ $2 = w
  -> $2 <= w
  -> wordToNat w - 2 = wordToNat w'.
  intros; apply (f_equal (fun x => x ^- $2)) in H.
  replace (w' ^+ $2 ^- $2) with w' in H by W_eq.
  subst.
  symmetry; apply wordToNat_wminus; auto.
Qed.

Lemma two_le : forall w : W,
  $2 <= w
  -> (2 <= wordToNat w)%nat.
  intros.
  destruct (le_lt_dec 2 (wordToNat w)); auto.
  elimtype False; apply H.
  pre_nomega.
  change (wordToNat (natToWord _ 2)) with 2 in *.
  omega.
Qed.

Lemma four_times_wordToNat : forall w : W,
  $(4 * wordToNat w) = $4 ^* w.
  intros; rewrite wmult_alt; auto.
Qed.

Lemma noWrapAround_weaken' : forall p sz sz',
  noWrapAround p sz
  -> (sz' <= sz)%nat
  -> noWrapAround p sz'.
  unfold noWrapAround; auto.
Qed.

Lemma the_ole_switcheroo : forall a b : W,
  a ^+ natToW 8 ^+ $(4 * wordToNat b) = a ^+ natToW 4 ^* (b ^+ natToW 2) ^+ $0.
  intros; replace (natToW 4 ^* (b ^+ natToW 2)) with ($4 ^* b ^+ $8) by words;
    rewrite four_times_wordToNat; words.
Qed.

Section ok.
  Ltac t := sep hints; eauto;
    try match goal with
          | [ H : freeable _ _ |- _ ] => destruct H; sep hints; eauto
        end;
    match goal with
      | [ H1 : noWrapAround _ (wordToNat ?sz - 1), H2 : _ <= ?sz |- _ ] =>
        specialize (noWrapAround_plus4 H1 H2); intro
      | [ H : _ |- _ ] => apply sub2 in H; [ | solve [ auto ] ]
    end; sep hints;
    repeat match goal with
             | [ H : _ <= _ |- _ ] => apply three_le in H
             | [ H : _ |- _ ] => apply two_le in H
           end; change (wordToNat (natToW 3)) with 3 in *;
    change (wordToNat (natToWord _ 3)) with 3 in *; eauto.

  Theorem ok : moduleOk m.
    vcgen; try t.

    Opaque mult.

    sep hints.

    Hint Rewrite wordToNat_wminus using nomega : N.

    Focus 4.
    eapply Himp_trans; [ eapply allocated_split | sepLemma ].
    nomega.
    apply allocated_shift_base.
    repeat match goal with
             | H:_ = _ |- _ => rewrite H
           end.
    apply the_ole_switcheroo.
    nomega.

    rewrite H9.
    rewrite <- four_times_wordToNat.
    apply H17.
    rewrite wordToNat_wplus.
    rewrite wordToNat_wminus.
    nomega.
    nomega.
    rewrite wordToNat_wminus by nomega.
    apply (goodSize_weaken (wordToNat x7)).
    apply goodSize_wordToNat.
    nomega.

    rewrite H9.
    split.
    pre_nomega.
    change (wordToNat (natToW 2)) with 2 in *.
    omega.

    eapply noWrapAround_weaken.
    eassumption.
    nomega.
    f_equal.
    rewrite (mult_comm 4).
    rewrite natToW_times4.
    rewrite wmult_comm.
    f_equal.
    transitivity (natToW (wordToNat x7 - wordToNat (sel x4 "n") + 2)).

    change 2 with (wordToNat (natToW 2)) at 2.
    match goal with
      | [ |- ?X ^+ _ = _ ] => rewrite <- (natToWord_wordToNat X)
    end.
    rewrite <- natToW_plus.
    rewrite wordToNat_wminus.
    auto.
    nomega.

    f_equal.
    Opaque minus.
    nomega.

    eapply noWrapAround_weaken'; [ eassumption | nomega ].

  Qed.
End ok.

Global Opaque freeable.


Require Import Coq.Lists.List.
Require Export Crypto.Util.FixCoqMistakes.
Import ListNotations.
Local Open Scope list_scope.

Module List.
  Definition combine_extend {A} {B}
    := fix combine_extend (defaultA : A) (defaultB : B) (l : list A) (l' : list B) {struct l} : list (A * B)
      := match l, l' with
         | [], [] => []
         | [], _ => List.map (fun y => (defaultA, y)) l'
         | _, [] => List.map (fun x => (x, defaultB)) l
         | x :: tl, y :: tl' => (x, y) :: combine_extend x y tl tl'
         end.
End List.


Require Import Arith List String Omega Bool.
Require Import Word.
Require Import Eqdep_dec.
Require Import Array.
Require Import Psatz.
Require Import ProofIrrelevance.
Require Import ListUtils.
Import ListNotations.
Open Scope string_scope.

Set Implicit Arguments.

Module Rec.

  Inductive type :=
    | WordF : nat -> type
    | ArrayF : type -> nat -> type
    | RecF : list (string * type) -> type.

  Definition rectype := list (string * type).

  (** Better induction principle *)
  Fixpoint type_rect_nest
      (P : type -> Type)
      (Q : rectype -> Type)
      (wordc : forall n, P (WordF n))
      (arrayc : forall t, P t -> forall n, P (ArrayF t n))
      (recc : forall rt : rectype, Q rt -> P (RecF rt))
      (nilc : Q nil)
      (consc : forall n t rt, P t -> Q rt -> Q ((n,t)::rt))
      (t : type) : P t :=
    match t as t0 return (P t0) with
    | WordF n => wordc n
    | ArrayF t' n => arrayc t' (type_rect_nest P Q wordc arrayc recc nilc consc t') n
    | RecF rt => recc rt (list_rect Q nilc (fun p r =>
        let (n, t') as p return (Q r -> Q (p :: r)) := p
        in consc n t' r (type_rect_nest P Q wordc arrayc recc nilc consc t')) rt)
    end.

  Fixpoint data (t : type) : Type :=
    match t with
    | WordF l => word l
    | ArrayF t' _ => list (data t')
    | RecF rt =>
      (fix recdata (t : list (string * type)) : Type :=
        match t with
        | [] => unit
        | (_, ft) :: t' => data ft * recdata t'
        end%type) rt
    end.

  Definition recdata ft := data (RecF ft).

  Fixpoint len (t : type) : nat :=
    match t with
    | WordF l => l
    | ArrayF t' l => l * len t'
    | RecF rt =>
      (fix reclen (t : rectype) : nat :=
        match t with
        | [] => 0
        | (_, ft) :: t' => len ft + reclen t'
        end) rt
    end.

  Fixpoint well_formed {t : type} : data t -> Prop :=
    match t as t return (data t -> Prop) with
    | WordF _ => fun _ => True
    | ArrayF _ l => fun v => Datatypes.length v = l /\ Forall well_formed v
    | RecF rt =>
      (fix well_formed' {rt : rectype} : data (RecF rt) -> Prop :=
        match rt as rt return (data (RecF rt) -> Prop) with
        | [] => fun _ => True
        | (_, ft) :: t' => fun r =>
          let (r0, r') := r in well_formed r0 /\ well_formed' r'
        end) rt
    end.

  Theorem firstn_well_formed : forall (ft:type) n1 n2 w,
    @well_formed (ArrayF ft (n1+n2)) w ->
    @well_formed (ArrayF ft n1) (firstn n1 w).
  Proof.
    intros.
    unfold well_formed in *.
    inversion H.
    split.
    rewrite firstn_length_l; omega.
    rewrite Forall_forall; intros.
    apply in_firstn_in in H2.
    rewrite Forall_forall in H1.
    apply H1.
    assumption.
  Qed.

  Theorem firstn_l_well_formed : forall (ft:type) n n' w,
    n <= n' ->
    @well_formed (ArrayF ft n') w ->
    @well_formed (ArrayF ft n) (firstn n w).
  Proof.
    intros.
    unfold well_formed in *.
    inversion H0.
    split.
    rewrite firstn_length_l; omega.
    rewrite Forall_forall in *; intros.
    eapply H2.
    eapply in_firstn_in; eauto.
  Qed.

  Theorem skipn_well_formed : forall (ft:type) n1 n2 w,
    @well_formed (ArrayF ft (n1+n2)) w ->
    @well_formed (ArrayF ft n2) (skipn n1 w).
  Proof.
    intros.
    unfold well_formed in *.
    inversion H.
    split.
    rewrite skipn_length; omega.
    rewrite Forall_forall; intros.
    apply in_skipn_in in H2.
    rewrite Forall_forall in H1.
    apply H1.
    assumption.
  Qed.

  Theorem tl_well_formed : forall (ft:type) n d w,
    @well_formed (ArrayF ft (S n)) (d::w) ->
    @well_formed (ArrayF ft n) w.
  Proof.
    intros.
    unfold well_formed in *.
    inversion H.
    split.
    simpl in *.
    omega.
    rewrite Forall_forall in *; intros.
    apply H1.
    constructor; assumption.
  Qed.

  Theorem empty_well_formed : forall (ft:type) w,
    List.length w = 0 ->
    @well_formed (ArrayF ft 0) w.
  Proof.
    intros.
    unfold well_formed.
    split; auto.
    apply length_nil in H.
    subst.
    auto.
  Qed.

  Inductive field_in : rectype -> string -> Prop :=
  | FE : forall t n ft, field_in ((n, ft) :: t) n
  | FS : forall t n n' ft, field_in t n -> field_in ((n', ft) :: t) n.

  Lemma empty_field_in : forall n, ~(field_in nil n).
  Proof.
    intros n f. inversion f.
  Qed.

  Lemma field_in_next : forall t n n' ft, n' <> n -> field_in ((n',ft) :: t) n -> field_in t n.
  Proof.
    intros t n n' ft ne f. inversion f; subst.
    contradiction ne. reflexivity.
    apply H3.
  Qed.

  Fixpoint field_type (t : rectype) (n : string) (f : field_in t n) : type :=
    match t as t return (field_in t n -> type) with
    | nil => fun f => match (empty_field_in f) with end
    | (n0, ft0)::_ => fun f =>
      match (string_dec n0 n) with
      | left _ => ft0
      | right ne => field_type (field_in_next ne f)
      end
    end f.

  Fixpoint recget {t : rectype} {n : string} (p : field_in t n) (r : recdata t) : data (field_type p) :=
    match t as t return (recdata t -> forall f : field_in t n, data (field_type f)) with
    | [] => fun _ f => match (empty_field_in f) with end
    | (n0, ft0) :: t' =>
      fun r f =>
      match (string_dec n0 n) as s
        return (data
            match s with
            | left _ => ft0
            | right ne => field_type (field_in_next ne f)
            end)
      with
      | left _ => (fst r)
      | right ne => recget (field_in_next ne f) (snd r)
      end
    end r p.

  Fixpoint recset {t : rectype} {n : string} (p : field_in t n) (r : recdata t) (v : data (field_type p)) {struct t} : recdata t.
    destruct t. contradiction (empty_field_in p).
    destruct p0 as [n0 ft0].
    simpl in v.
    destruct (string_dec n0 n) as [eq|neq]; constructor.
    apply v. apply (snd r).
    apply (fst r). apply (recset t n (field_in_next neq p) (snd r) v).
  Defined.
  (* TODO: define recset without tactics (somewhat messy) *)

  Theorem set_get_same : forall t n p r v, @recget t n p (recset p r v) = v.
  Proof.
    induction t; intros.
    contradiction (empty_field_in p).
    destruct a as [n0 ft0]. destruct r as [v0 r'].
    simpl in v. simpl. destruct (string_dec n0 n).
    trivial. apply IHt.
  Qed.

  Theorem set_get_other : forall t n1 p1 n2 p2 r v, n1 <> n2 ->
    recget p1 r = @recget t n1 p1 (@recset t n2 p2 r v).
  Proof.
    induction t; intros n1 p1 n2 p2 r v neq.
    contradiction (empty_field_in p1).
    destruct a as [n0 ft0]. destruct r as [v0 r'].
    simpl in v. simpl.
    destruct (string_dec n0 n2); destruct (string_dec n0 n1);
      subst; trivial.
    contradiction neq. auto.
    apply IHt. assumption.
  Qed.

  Fixpoint fieldp (t : rectype) (n : string) : option (field_in t n) :=
    match t as t return (option (field_in t n)) with
    | [] => None
    | (n0, l0) :: t' =>
      match (string_dec n0 n) with
      | left e =>
          eq_rec_r
            (fun n1 => option (field_in ((n1, l0) :: t') n))
            (Some (FE t' n l0)) e
      | right _ =>
        match (fieldp t' n) with
        | Some f => Some (FS n0 l0 f)
        | None => None
        end
      end
    end.

  Definition recget' {t : rectype} (n : string) (r : recdata t) :=
    match fieldp t n as fp
          return (match fp with
                    | Some p => data (field_type p)
                    | None => True
                  end) with
      | Some p => recget p r
      | None => I
    end.

  Definition recset' {t : rectype} (n : string) (r : recdata t) :=
    match fieldp t n as fp
          return (recdata t -> match fp with
                    | Some p => data (field_type p) -> recdata t
                    | None => True
                  end) with
      | Some p => fun r v => recset p r v
      | None => fun _ => I
    end r.

  Fixpoint to_word {ft : type} : data ft -> word (len ft) :=
    match ft as ft return (data ft -> word (len ft)) with
    | WordF n => fun v => v
    | ArrayF ft0 n as ft =>
      (fix arrayf2word n v :=
        match n as n0 return (data (ArrayF ft0 n0) -> word (len (ArrayF ft0 n0))) with
        | 0 => fun _ => $0
        | S n0 => fun v =>
          match v with
          | nil => $0
          | v0 :: v' => combine (to_word v0) (arrayf2word n0 v')
          end
        end v) n
    | RecF t =>
      (fix rec2word {t : rectype} (r : recdata t) : word (len (RecF t)) :=
        match t as t return recdata t -> word (len (RecF t)) with
        | nil => fun _ => $0
        | (_, _) :: _ => fun r =>
          let (v, r') := r in combine (to_word v) (rec2word r')
        end r) t
    end.

  Fixpoint of_word {ft : type} : word (len ft) -> data ft :=
    match ft as ft return (word (len ft) -> data ft) with
    | WordF n => fun w => w
    | ArrayF ft0 n as ft =>
      (fix word2arrayf n w :=
        match n as n return (word (len (ArrayF ft0 n)) -> data (ArrayF ft0 n)) with
        | 0 => fun _ => []
        | S n' => fun w0 =>
          (of_word (split1 (len ft0) _ w0)) ::
          (word2arrayf n' (split2 (len ft0) _ w0))
        end w) n
    | RecF t =>
      (fix word2rec (t : rectype) (w : word (len (RecF t))) : recdata t :=
        match t as t return word (len (RecF t)) -> recdata t with
        | nil => fun _ => tt
        | (_, ft) :: t' => fun w =>
          (of_word (split1 (len ft) (len (RecF t')) w),
           word2rec t' (split2 (len ft) (len (RecF t')) w))
        end w) t
  end.

  Theorem to_of_id : forall ft w, to_word (@of_word ft w) = w.
  Proof.
    einduction ft using type_rect_nest; simpl.
    reflexivity.
    induction n.
    auto.
    intro w. simpl in *. rewrite IHn. rewrite IHt. apply combine_split.
    apply IHt.
    intro w. rewrite word0. trivial.
    simpl. intro w.
    rewrite IHt. rewrite IHt0. apply combine_split.
  Qed.

  Hint Rewrite to_of_id.

  Theorem of_to_id : forall ft v, well_formed v -> of_word (@to_word ft v) = v.
  Proof.
    einduction ft using type_rect_nest.
    reflexivity.
    induction n; intros v H; simpl in v.
    destruct H. destruct v; try discriminate. reflexivity.
    simpl in *. destruct H. destruct v; try discriminate.
    rewrite split1_combine. rewrite split2_combine.
    inversion H0. subst. rewrite IHt by assumption. rewrite IHn by auto. trivial.
    2: instantiate (1 := fun rt => forall v,
      (fix well_formed' {rt : rectype} : data (RecF rt) -> Prop :=
        match rt as rt return (data (RecF rt) -> Prop) with
        | [] => fun _ => True
        | (_, ft) :: t' => fun r =>
          let (r0, r') := r in well_formed r0 /\ well_formed' r'
        end) rt v ->
      (fix word2rec (t : rectype) (w : word (len (RecF t))) : recdata t :=
        match t as t return word (len (RecF t)) -> recdata t with
        | nil => fun _ => tt
        | (_, ft) :: t' => fun w =>
          (of_word (split1 (len ft) (len (RecF t')) w),
           word2rec t' (split2 (len ft) (len (RecF t')) w))
        end w)
        rt
        ((fix rec2word {t : rectype} (r : recdata t) : word (len (RecF t)) :=
          match t as t return recdata t -> word (len (RecF t)) with
          | nil => fun _ => WO
          | (_, _) :: _ => fun r =>
            let (v, r') := r in combine (to_word v) (rec2word r')
          end r) rt v) = v).
    apply IHt.
    simpl. intros v t. destruct v. trivial.
    simpl. intro v. destruct v. intro Hrl. destruct Hrl.
    rewrite split1_combine. rewrite split2_combine.
    rewrite IHt0 by assumption. rewrite IHt by assumption. trivial.
  Qed.

  Theorem to_eq : forall ft a b,
    @to_word ft a = @to_word ft b ->
    well_formed a ->
    well_formed b ->
    a = b.
  Proof.
    intros.
    rewrite <- Rec.of_to_id with (v := a) by auto.
    rewrite <- Rec.of_to_id with (v := b) by auto.
    congruence.
  Qed.

  Theorem of_eq : forall ft a b,
    @of_word ft a = @of_word ft b ->
    a = b.
  Proof.
    intros.
    rewrite <- Rec.to_of_id with (w := a).
    rewrite <- Rec.to_of_id with (w := b).
    congruence.
  Qed.

  Lemma of_word_empty : forall t n w,
    n = 0 ->
    @of_word (ArrayF t n) w = nil.
  Proof.
    intros.
    generalize w.
    rewrite H.
    intros.
    simpl in w0.
    apply length_nil.
    reflexivity.
  Qed.

  Theorem of_word_length : forall ft w, well_formed (@of_word ft w).
  Proof.
    einduction ft using type_rect_nest.
    simpl. trivial.
    simpl. induction n.
    split; trivial.
    intro w.
    edestruct IHn.
    split. simpl. rewrite H. trivial.
    simpl. constructor. apply IHt. assumption.
    apply IHt.
    simpl. trivial.
    simpl. intro w. split.
    apply IHt. apply IHt0.
  Qed.

  Theorem of_word_well_formed : forall (ft:type) w,
    well_formed (@of_word ft w).
  Proof.
    apply of_word_length.
  Qed.

  Theorem array_of_word_length : forall ft n w,
    List.length (@of_word (ArrayF ft n) w) = n.
  Proof.
    induction n; intros; simpl.
    reflexivity.
    f_equal.
    apply IHn.
  Qed.

  Theorem to_word_append_any: forall sz l n l2,
    Datatypes.length l > n -> @to_word (ArrayF (WordF sz) n) (app l l2) = @to_word (ArrayF (WordF sz) n) l.
  Proof.
    simpl.
    induction l; simpl; induction n; intros; auto; try omega.
    f_equal.
    apply IHl.
    omega.
  Qed.

  Theorem to_word_append_zeroes: forall sz l n m,
    @to_word (ArrayF (WordF sz) n) (app l (repeat $0 m)) = @to_word (ArrayF (WordF sz) n) l.
  Proof.
    simpl.
    induction l; simpl; induction n; intros; auto.
    + induction m; simpl; auto.
      induction n; try rewrite IHn;
      apply combine_wzero.
    + f_equal.
      apply IHl.
  Qed.

  Arguments of_word : simpl never.
  Arguments to_word : simpl never.

  (**
   * Efficient implementations for fetching or updating a single element from a
   * [word (len (ArrayF ft len))], without decoding/encoding the whole word to
   * and from the corresponding [list (data ft)].
   *)

  Definition middle (low mid high : nat) (w : word (low + (mid + high))) : word mid :=
    split1 mid high (split2 low (mid+high) w).

  Lemma word_selN_helper : forall idx l lenft, idx < l ->
    l * lenft = idx * lenft + (lenft + (l * lenft - lenft - idx * lenft)).
  Proof.
    intros.
    rewrite plus_assoc.
    rewrite Nat.add_sub_assoc.
    rewrite <- plus_assoc.
    rewrite plus_comm.
    rewrite <- Nat.add_sub_assoc by omega.
    rewrite Nat.sub_diag; rewrite <- plus_n_O.
    rewrite Nat.add_sub_assoc.
    rewrite plus_comm.
    rewrite <- Nat.add_sub_assoc by omega.
    rewrite Nat.sub_diag; rewrite <- plus_n_O.
    reflexivity.
    replace (lenft) with (1 * lenft) at 1 by omega.
    apply Nat.mul_le_mono_r; omega.
    replace (lenft) with (1 * lenft) at 3 by omega.
    rewrite <- Nat.mul_sub_distr_r.
    apply Nat.mul_le_mono_r; omega.
  Qed.

  Definition word_selN {ft : type} {l : nat} (idx : nat) (w : word (len (ArrayF ft l))) : word (len ft).
    refine (if lt_dec idx l then _ else $0).
    refine (middle (idx * len ft) (len ft) (l * len ft - len ft - idx * len ft) _).
    replace (idx * len ft + (len ft + (l * len ft - len ft - idx * len ft))) with (l * len ft).
    exact w.
    apply word_selN_helper.
    apply l0.
  Defined.

  Theorem word_selN_equiv : forall ft l idx w def, idx < l ->
    of_word (@word_selN ft l idx w) = selN (of_word w) idx def.
  Proof.
    induction l; intros; try omega.
    unfold of_word in *; fold (@of_word ft) in *.
    destruct idx; simpl.
    - f_equal. clear IHl.
      unfold word_selN, middle.

      destruct (lt_dec 0 (S l)); [|omega].
      generalize (word_selN_helper (len ft) l0).
      replace (S l * len ft - len ft - 0 * len ft) with (l * len ft) by lia.
      simpl; intros.
      erewrite <- eq_rect_eq.
      reflexivity.

    - rewrite <- IHl by omega; clear IHl.
      f_equal.
      unfold word_selN.
      destruct (lt_dec (S idx) (S l)); try omega.
      destruct (lt_dec idx l); try omega.

      unfold middle.

      generalize (word_selN_helper (len ft) l0).
      generalize (word_selN_helper (len ft) l1).
      replace (S l * len ft - len ft - S idx * len ft)
        with (l * len ft - len ft - idx * len ft) by lia.
      generalize (l * len ft - len ft - idx * len ft).

      intros.
      fold len. fold Init.Nat.mul.
      f_equal.
      generalize dependent e0.
      generalize dependent e.
      generalize (len ft + n); clear n.
      generalize dependent w; simpl.
      generalize (idx * len ft).
      generalize (l * len ft); clear H l0 l1 l def idx.
      generalize (len ft); clear ft.
      intros.

      assert (n + n0 = n + (n1 + n2)) as e0' by omega.
      replace ((eq_rect (n + n0) (fun n => word n) w (n + n1 + n2) e0))
        with (match plus_assoc _ _ _ in _ = N return word N with
              | refl_equal => (eq_rect (n+n0) (fun n => word n) w (n+(n1+n2)) e0')
              end).

      rewrite <- split2_iter.
      f_equal.
      generalize dependent e0'; clear e0.
      rewrite <- e; intros.
      repeat rewrite <- eq_rect_eq.
      reflexivity.

      destruct (Nat.add_assoc n n1 n2).
      destruct e0.
      repeat rewrite <- eq_rect_eq.
      reflexivity.
  Qed.

  Lemma word_updN_helper1 : forall idx l lenft, idx < l ->
    lenft + (l * lenft - idx * lenft - lenft) = l * lenft - idx * lenft.
  Proof.
    intros.

    rewrite Nat.add_sub_assoc. rewrite plus_comm. rewrite <- Nat.add_sub_assoc by omega.
    rewrite Nat.sub_diag. omega.

    rewrite <- Nat.mul_sub_distr_r. replace (lenft) with (1 * lenft) at 1 by omega.
    apply Nat.mul_le_mono_r; omega.
  Qed.

  Lemma word_updN_helper2 : forall idx l lenft, idx < l ->
    idx * lenft + (l * lenft - idx * lenft) = l * lenft.
  Proof.
    intros.

    rewrite Nat.add_sub_assoc. rewrite plus_comm. rewrite <- Nat.add_sub_assoc by omega.
    rewrite Nat.sub_diag. omega.

    apply Nat.mul_le_mono_r; omega.
  Qed.

  Definition word_updN {ft : type} {l : nat} (idx : nat) (w : word (len (ArrayF ft l)))
                                             (v : word (len ft)) : word (len (ArrayF ft l)).
    refine (if lt_dec idx l then _ else w); simpl in *.

    replace (l * len ft) with (idx * len ft + (l * len ft - idx * len ft))
      in * by (apply word_updN_helper2; assumption).
    remember (split1 (idx * len ft) (l * len ft - idx * len ft) w) as low; clear Heqlow.
    refine (combine low _).

    replace (l * len ft - idx * len ft) with (len ft + (l * len ft - idx * len ft - len ft))
      in * by (apply word_updN_helper1; assumption).
    rewrite plus_assoc in *.

    remember (split2 (idx * len ft + len ft) (l * len ft - idx * len ft - len ft) w) as hi; clear Heqhi.
    refine (combine v hi).
  Defined.

  Theorem word_updN_oob : forall ft l idx w v, idx >= l ->
    @word_updN ft l idx w (to_word v) = w.
  Proof.
    unfold word_updN; simpl; intros.
    destruct (lt_dec idx l); auto.
    exfalso; omega.
  Qed.

  Theorem word_updN_equiv : forall ft l idx w v, idx < l ->
    @word_updN ft l idx w (to_word v) = @to_word (ArrayF ft l) (updN (of_word w) idx v).
  Proof.
    simpl; intros.
    unfold word_updN.
    destruct (lt_dec idx l); try omega; clear H.

    unfold eq_rec_r, eq_rec.
    rewrite eq_rect_word_offset.
    repeat rewrite eq_rect_nat_double.

    generalize (word_updN_helper1 (len ft) l0).
    generalize (word_updN_helper2 (len ft) l0).

    generalize dependent l.
    induction idx; simpl; intros.
    - destruct l; try omega.
      unfold of_word; fold (@of_word ft).
      unfold to_word; fold (@to_word ft).
      replace ((fix word2arrayf (n : nat) (w0 : word (n * len ft)) {struct n} :
         list (data ft) :=
           match n as n0 return (word (len (ArrayF ft n0)) -> data (ArrayF ft n0)) with
           | 0 => fun _ : word (len (ArrayF ft 0)) => []
           | S n' =>
               fun w1 : word (len (ArrayF ft (S n'))) =>
               of_word (split1 (len ft) (n' * len ft) w1)
               :: word2arrayf n' (split2 (len ft) (n' * len ft) w1)
           end w0) l (split2 (len ft) (l * len ft) w))
        with (@of_word (ArrayF ft l) (split2 (len ft) (l * len ft) w)) by reflexivity.
      simpl.

      repeat rewrite eq_rect_nat_double.
      rewrite eq_rect_combine.
      f_equal.
      rewrite eq_rect_split2.
      rewrite eq_rect_nat_double.
      rewrite <- (eq_rect_eq_dec eq_nat_dec).
      match goal with
      | [ |- _ = ?r ] =>
        replace (r)
          with (@to_word (ArrayF ft l) (of_word (split2 (len ft) (len (ArrayF ft l)) w)))
          by reflexivity
      end.
      rewrite to_of_id.
      reflexivity.

    - destruct l; try omega.
      unfold of_word; fold (@of_word ft). fold Init.Nat.mul. fold len.
      unfold to_word; fold (@to_word ft). fold Init.Nat.mul. fold len.
      fold recdata. fold data.
      match goal with
      | [ |- _ = match updN (_ :: ?x) _ _ with | nil => _ | v0 :: v' => _ end ] =>
        replace (x) with (@of_word (ArrayF ft l) (split2 (len ft) (l * len ft) w)) by reflexivity
      end.
      simpl.

      rewrite to_of_id.
      assert (idx < l) as Hidx by omega.
      specialize (IHidx l (split2 (len ft) (l * len ft) w) Hidx).
      clear l0.

      generalize dependent e; generalize dependent e0. simpl.
      replace (len ft + l * len ft - (len ft + idx * len ft))
        with (len ft + (l * len ft - len ft - idx * len ft)) by
        ( rewrite Nat.sub_add_distr;
          rewrite minus_plus;
          rewrite <- word_updN_helper1 by omega;
          lia ).
      intros.
      rewrite eq_rect_combine.
      rewrite eq_rect_split2.
      repeat rewrite eq_rect_nat_double.

      repeat match goal with
      | [ |- context[(eq_trans ?a ?b)] ] =>
        generalize (eq_trans a b); intros
      end.
      clear e0.

      rewrite <- combine_split with (sz1:=len ft) (sz2:=idx * len ft)
        (w:=(split1 (len ft + idx * len ft) (len ft + (l * len ft - len ft - idx * len ft))
        (eq_rect (len ft + l * len ft) (fun y : nat => word y) w
           (len ft + idx * len ft + (len ft + (l * len ft - len ft - idx * len ft)))
           (eq_sym e)))).
      assert (len ft + (idx * len ft + (len ft + (l * len ft - len ft - idx * len ft))) =
              len ft + idx * len ft + (len ft + (l * len ft - len ft - idx * len ft)))
        as Hassoc by lia.
      rewrite (combine_assoc _ _ _ Hassoc).
      rewrite eq_rect_word_match.
      rewrite eq_rect_nat_double.
      rewrite eq_rect_combine.
      f_equal.

      rewrite split1_iter with (Heq:=eq_sym Hassoc).
      rewrite eq_rect_word_match.
      rewrite eq_rect_nat_double.
      generalize dependent (eq_trans (eq_sym e) (eq_sym Hassoc)).
      replace (idx * len ft + (len ft + (l * len ft - len ft - idx * len ft)))
        with (l * len ft) by lia.
      intros.
      rewrite <- (eq_rect_eq_dec eq_nat_dec). reflexivity.

      unfold to_word in IHidx; fold (@to_word ft) in IHidx; simpl in IHidx.
      fold data in IHidx. fold len in IHidx. fold Init.Nat.mul in IHidx.
      erewrite <- IHidx.

      repeat rewrite eq_rect_split2.
      assert (len ft + (idx * len ft + len ft + (l * len ft - idx * len ft - len ft)) =
        len ft + (idx * len ft + len ft) + (l * len ft - idx * len ft - len ft))
        as Hs2iter by lia.
      rewrite split2_iter with (Heq:=Hs2iter).
      rewrite eq_rect_word_match.
      rewrite eq_rect_nat_double.

      rewrite <- eq_rect_combine.
      rewrite eq_rect_nat_double.

      repeat match goal with
      | [ |- context[eq_sym ?a] ] => generalize (eq_sym a); intros
      | [ |- context[eq_trans ?a ?b] ] => generalize (eq_trans a b); intros
      | [ |- context[eq_rect_split2_helper ?a ?b] ] => generalize (eq_rect_split2_helper a b); intros
      end; clear.

      generalize dependent idx; intro idx.
      replace (l * len ft - idx * len ft - len ft)
        with (l * len ft - len ft - idx * len ft) by lia.
      intros.
      f_equal; clear.
      f_equal; clear.

      erewrite split1_split2.
      rewrite eq_rect_word_match.
      rewrite eq_rect_nat_double.
      f_equal; clear.

      assert (len ft + (l * len ft - len ft - idx * len ft) = l * len ft - idx * len ft)
        as Hr by lia.
      generalize dependent e0; generalize dependent e7.
      rewrite Hr.
      intros.
      f_equal; clear.
      f_equal; clear.
      apply UIP_dec; exact eq_nat_dec.

      f_equal; clear.
      generalize dependent idx; intro idx.
      replace (len ft + (idx * len ft + len ft))
        with (len ft + idx * len ft + len ft) by lia.
      intros.
      f_equal; clear.
      f_equal; clear.
      apply UIP_dec; exact eq_nat_dec.
      apply UIP_dec; exact eq_nat_dec.
      Grab Existential Variables.
      rewrite plus_assoc; reflexivity.
      lia.
      lia.
  Qed.

  Definition word_mask (l n : nat) (idx : nat) : word (l * n).
    destruct l eqn:H.
    exact (wzero 0).
    exact (wlshift (combine (wones n) (wzero (n0 * n))) (idx * n)).
  Defined.

  Definition word_selN_shift (l n : nat) (idx : nat) (w : word (l * n)) : word n.
    destruct l eqn:H.
    exact (wzero n).
    exact (split1 n (n0 * n) (wrshift w (idx * n))).
  Defined.

  Definition word_updN_shift (l n : nat) (idx : nat) (w : word (l * n))
                                             (v : word n) : word (l * n).
    destruct l eqn:H.
    exact w.
    set (v' := zext v (n0 * n)).
    set (mask := word_mask (S n0) n idx).
    set (shift := n * idx).
    set (newmask := wlshift v' shift).
    exact ((w ^& (wnot mask)) ^| newmask).
  Defined.

  Fact word_shift_helper1 : forall n idx off, n + (idx + off) * n = (idx + 1 + off) * n.
  Proof. intros. lia. Qed.

  Fact word_shift_helper2 : forall n l, l > 0 -> n + (l - 1) * n = l * n.
  Proof. intros. destruct l; simpl; try rewrite <- minus_n_O; omega. Qed.

  Fact word_shift_helper3 : forall a b c, a * c + (c + b * c) = (a + 1 + b) * c.
  Proof. intros. lia. Qed.

  Fact word_shift_helper4 : forall a b c, (a + 1 + b) * c = a * c + c + b * c.
  Proof. intros. lia. Qed.

  Theorem word_selN_shift_gt_0 : forall idx off n w,
    word_selN_shift (idx + 1 + off) n idx w = split1 n ((idx + off) * n)
      (eq_rect _ word (wrshift w (idx * n)) _ (eq_sym (word_shift_helper1 n idx off))).
  Proof.
    intros idx off n.
    assert (idx + 1 + off = S (idx + off)) as H by omega.
    generalize_proof.
    rewrite H.
    intros.
    eq_rect_simpl.
    reflexivity.
  Qed.

  Theorem eq_rect_combine_dist3 : forall a b c (w : word ((a + 1 + b) * c)),
    let H := word_shift_helper3 a b c in
    let H1 := word_shift_helper4 a b c in
    let w' := eq_rect ((a + 1 + b) * c) word w _ (eq_sym H) in
    let w'' := eq_rect ((a + 1 + b) * c) word w _ H1 in
    w = eq_rect _ word (combine
      (split1 (a * c) _ w')
      (combine
        (middle (a * c) c (b * c) w')
        (split2 (a * c + c) (b * c) w''))) _ H.
  Proof.
    intros.
    generalize dependent H1.
    generalize dependent w.
    generalize dependent H.
    intros H.
    rewrite <- H.
    intros.
    subst w' w''.
    eq_rect_simpl.
    unfold middle.
    rewrite <- combine_split with (w := w).
    repeat f_equal; rewrite combine_split; auto.
    erewrite <- eq_rect_word_match.
    rewrite combine_end.
    reflexivity.
  Qed.

  Fact eq_rect_both_helper : forall T (x y z : T), x = y -> z = y -> z = x.
  Proof. intros. subst. reflexivity. Qed.

  Theorem eq_rect_both : forall x y z (H1 : x = z) (H2 : y = z) wa wb,
    wa = eq_rect y word wb x (eq_rect_both_helper H1 H2) -> eq_rect x word wa z H1 = eq_rect y word wb z H2.
  Proof.
    intros. subst.
    eq_rect_simpl.
    reflexivity.
   Qed.

  Fact split1_eq_rect_combine_partial_helper : forall a b c d (H : a + c = a + b + d), c = b + d.
  Proof. intros. omega. Qed.

  Theorem split1_eq_rect_combine_partial : forall a b c d H (wa : word a) (wc : word c),
    split1 (a + b) d
      (eq_rect (a + c) word (combine wa wc) (a + b + d) H) =
        combine wa (split1 b d (eq_rect _ word wc _ (split1_eq_rect_combine_partial_helper a b c d H))).
  Proof.
    intros a b c d H.
    assert (c = b + d) by omega; subst c.
    intros.
    erewrite <- split1_combine; f_equal.
    eq_rect_simpl.
    erewrite combine_assoc.
    rewrite eq_rect_word_match.
    rewrite combine_split.
    reflexivity.
  Qed.

  Fact combine_eq_rect_combine_helper : forall a b c d, a + b = c -> a + (b + d) = c + d.
  Proof. intros. omega. Qed.

  Fact combine_eq_rect_combine : forall a b c d H (wa : word a) (wb : word b) (wa' : word d),
    combine (eq_rect (a + b) word (combine wa wb) c H) wa' =
    eq_rect _ word (combine wa (combine wb wa')) _ (combine_eq_rect_combine_helper a b d H).
  Proof.
    intros a b c d H.
    subst c.
    intros.
    eq_rect_simpl.
    erewrite combine_assoc, eq_rect_word_match.
    reflexivity.
  Qed.

  Fact split2_eq_rect_combine : forall a b c H (wa : word a) (wc : word c),
    split2 a b (eq_rect (a + c) word (combine wa wc) (a + b) H) =
    eq_rect c word wc b (plus_reg_l c b a H).
  Proof.
    intros a b c H.
    assert (c = b) by omega; subst.
    intros.
    eq_rect_simpl.
    apply split2_combine.
  Qed.

  Theorem word_selN_shift_eq_middle : forall idx off n w,
    @word_selN_shift (idx + 1 + off) n idx w = middle (idx * n) n (off * n)
      (eq_rec _ word w _ (eq_sym (word_shift_helper3 idx off n))).
  Proof.
    intros.
    eq_rect_simpl.
    rewrite word_selN_shift_gt_0.
    generalize_proof.
    replace ((idx + off) * n) with (idx * n + off * n) by lia.
    intros HH.
    unfold wrshift.
    eq_rect_simpl.
    erewrite combine_eq_rect2.
    rewrite eq_rect_combine_dist3 with (w := w); eq_rect_simpl.
    erewrite combine_eq_rect_combine; eq_rect_simpl.
    erewrite split2_eq_rect_combine; eq_rect_simpl.
    repeat erewrite combine_assoc, eq_rect_word_match; eq_rect_simpl.
    unfold middle.
    repeat progress (rewrite eq_rect_combine ||
                     rewrite split1_combine  ||
                     rewrite split2_combine).
    reflexivity.
    Grab Existential Variables.
    all : lia.
  Qed.

  Theorem word_selN_shift_equiv : forall ft l idx w, idx < l ->
    @word_selN ft l idx w = @word_selN_shift l (len ft) idx w.
  Proof.
    intros.
    generalize dependent w.
    remember (l - idx - 1) as off.
    assert (l = (idx + 1+ off)) by omega.
    subst l.
    intros w.
    unfold word_selN.
    destruct lt_dec; try omega.
    erewrite word_selN_shift_eq_middle.
    generalize dependent (word_selN_helper (len ft) l).
    replace ((idx + 1 + off) * len ft - len ft - idx * len ft) with (off * len ft) by lia.
    intros HH.
    f_equal.
    apply eq_rect_both; eq_rect_simpl.
    reflexivity.
  Qed.

  Definition word_selN' {ft : type} {l : nat} (idx : nat) (w : word (len (ArrayF ft l)))
    : word (len ft) := @word_selN_shift l (len ft) idx w.

  Theorem word_selN'_equiv : forall ft l idx w def, idx < l ->
    of_word (@word_selN' ft l idx w) = selN (of_word w) idx def.
  Proof.
    intros.
    unfold word_selN'.
    rewrite <- word_selN_shift_equiv; auto.
    apply word_selN_equiv; auto.
  Qed.

  Theorem word_updN_shift_l_gt_0 : forall idx off n w v,
    @word_updN_shift (idx + 1 + off) n idx w v = w ^& wnot (word_mask (idx + 1 + off) n idx) ^| wlshift (
      eq_rect _ word (zext v ((idx + off) * n)) _ (word_shift_helper1 n idx off)) (idx * n).
  Proof.
    unfold word_updN_shift.
    intros idx off n.
    generalize dependent (word_shift_helper1 n idx off).
    replace (idx + 1 + off) with (S (idx + off)) by omega.
    intros.
    eq_rect_simpl.
    f_equal.
    f_equal.
    apply mult_comm.
  Qed.

  Theorem word_mask_l_gt_0 : forall l n idx (H : l > 0),
    @word_mask l n idx = wlshift (eq_rect _ word (combine (wones n) (wzero ((l - 1) * n))) _
      (word_shift_helper2 n H))
      (idx * n).
  Proof.
    unfold word_mask; destruct l; auto; intros.
    erewrite combine_eq_rect2.
    repeat f_equal.
    generalize_proof.
    intros HH; rewrite HH; auto.
    Grab Existential Variables.
    simpl; rewrite <- minus_n_O.
    reflexivity.
  Qed.

  Theorem wnot_word_mask_l_gt_0 : forall off n idx,
    wnot (@word_mask (idx + 1 + off) n idx) = eq_rec _ word (
    combine (wones (idx * n)) (combine (wzero n) (wones (off * n)))) ((idx + 1 + off) * n)
      (word_shift_helper3 idx off n).
  Proof.
    intros off n idx.
    generalize dependent (word_shift_helper3 idx off n).
    replace (idx + 1 + off) with (S (idx + off)) by omega.
    intros H.
    unfold word_mask.
    rewrite wnot_wlshift.
    eq_rect_simpl.
    erewrite split1_eq_rect_eq1; f_equal.
    eq_rect_simpl.
    rewrite split1_eq_rect_combine_partial; f_equal.
    rewrite wnot_combine, wnot_ones.
    rewrite split1_eq_rect_combine_partial; f_equal.
    erewrite wzero_dist, wzero_rev, <- combine_wzero.
    repeat rewrite wnot_eq_rect.
    eq_rect_simpl.
    rewrite wnot_combine, split1_combine.
    apply wnot_zero.
    Grab Existential Variables.
    all : lia.
  Qed.

  Lemma wand_wnot_word_mask_w : forall idx off n w,
    let H := word_shift_helper3 idx off n in
    let w' := eq_rect _ word w (idx * n + (n + off * n)) (eq_sym H) in
    let w'' := eq_rect _ word w (idx * n + n + off * n) (word_shift_helper4 idx off n) in
    w ^& wnot (word_mask (idx + 1 + off) n idx) = eq_rec _ word (
      combine (split1 (idx * n) _ w') (combine (wzero n) (split2 (idx * n + n) _ w''))) _ H.
  Proof.
    intros.
    erewrite eq_rect_combine_dist3 with (w := w).
    erewrite wnot_word_mask_l_gt_0 by omega.
    unfold wand.
    unfold eq_rec.
    erewrite <- eq_rect_bitwp'; f_equal.
    repeat erewrite <- combine_bitwp; f_equal.
    - rewrite wand_comm, wand_wones.
      reflexivity.
    - rewrite wand_comm, wand_wzero.
      rewrite wand_comm, wand_wones.
      reflexivity.
  Qed.

  Theorem word_updN_shift_abs : forall off idx n w v,
    let H := word_shift_helper3 idx off n in
    let H1 := word_shift_helper4 idx off n in
    let w' := eq_rec _ word w _ (eq_sym H) in
    let w'' := eq_rec _ word w _ H1 in
    @word_updN_shift (idx + 1 + off) n idx w v = eq_rec _ word (
      combine (split1 (idx * n) (n + off * n) w')
      (combine v (split2 (idx * n + n) (off * n) w''))) _ H.
  Proof.
    intros.
    assert ((idx + 1 + off) * n = idx * n + n + off * n) as Hc by lia.
    erewrite eq_rect_combine_dist3 with (w := w).
    erewrite word_updN_shift_l_gt_0.
    erewrite wand_wnot_word_mask_w.
    unfold wlshift, zext.
    eq_rect_simpl.
    rewrite split1_combine.
    rewrite eq_rect_combine_assoc'.
    rewrite split2_combine.
    unfold wor.
    rewrite eq_rect_bitwp_1.
    f_equal.
    replace (eq_rect ((idx + 1 + off) *n) word (split1 _ (idx * n) _) _ _)
      with (combine (wzero (idx * n)) (combine v (wzero (off * n)))).
    - repeat rewrite <- combine_bitwp.
      repeat rewrite wor_wzero.
      repeat try (rewrite wor_comm, wor_wzero).
      reflexivity.
    - erewrite split1_eq_rect_eq1.
      repeat (eq_rect_simpl; erewrite split1_eq_rect_combine_partial; f_equal).
      erewrite wzero_dist, wzero_rev, <- combine_wzero.
      eq_rect_simpl.
      symmetry; apply split1_combine.
    Grab Existential Variables.
    all : lia.
  Qed.

  Fact word_updN_abs_helper : forall idx off, idx < idx + 1 + off.
  Proof. intros. omega. Qed.

  Theorem word_updN_abs : forall idx off ft w v,
    let H := word_shift_helper3 idx off (len ft) in
    let H1 := word_shift_helper4 idx off (len ft) in
    let w' := eq_rec _ word w _ (eq_sym H) in
    let w'' := eq_rec _ word w _ H1 in
    @word_updN ft (idx + 1 + off) idx w v = eq_rec _ word (
      combine (split1 (idx * len ft) (len ft + off * len ft) w')
        (combine v (split2 (idx * len ft + len ft) (off * len ft) w''))) _ H.
  Proof.
    unfold word_updN; simpl.
    intros.
    destruct lt_dec; try omega.
    repeat eexists.
    eq_rect_simpl; apply eq_rect_both.
    rewrite eq_rect_word_offset; eq_rect_simpl.
    rewrite eq_rect_combine; f_equal.
    + erewrite eq_rect_split1_eq2.
      eq_rect_simpl; f_equal.
      apply eq_rect_both.
      eq_rect_simpl; reflexivity.
    + apply eq_rect_both.
      rewrite eq_rect_combine.
      rewrite eq_rect_split2.
      eq_rect_simpl.
      repeat (try reflexivity; f_equal; eq_rect_simpl; try apply eq_rect_both).
    Grab Existential Variables.
    all : simpl; lia.
  Qed.

  Theorem word_updN_shift_equiv : forall l idx ft w v, idx < l ->
    @word_updN_shift l (len ft) idx w v = @word_updN ft l idx w v.
  Proof.
    intros l idx ft w v H.
    remember (l - idx - 1) as off.
    assert (l = idx + 1 + off) by omega.
    subst l.
    erewrite word_updN_shift_abs by auto.
    erewrite word_updN_abs.
    repeat f_equal.
  Qed.

  Definition word_updN' {ft : type} {l : nat} (idx : nat) (w : word (len (ArrayF ft l)))
            (v : word (len ft)) : word (len (ArrayF ft l)) := @word_updN_shift l (len ft) idx w v.

  Theorem word_updN'_equiv : forall ft l idx w v, idx < l ->
    @word_updN' ft l idx w (to_word v) = @to_word (ArrayF ft l) (updN (of_word w) idx v).
  Proof.
    intros.
    unfold word_updN'.
    rewrite word_updN_shift_equiv; auto.
    apply word_updN_equiv; auto.
  Qed.

  Program Fixpoint word_concat {ft : type} (items : list (word (len ft)))
    : word ((len ft) * (List.length items)) :=
    match items with
    | nil => $0
    | m :: rest => combine m (@word_concat ft rest)
    end.
  Next Obligation.
  abstract nia.
  Defined.

  Fixpoint reczero (ft : type) : (data ft).
  Proof.
    destruct ft.
    - exact ($ 0).
    - apply repeat.
      apply reczero.
      exact n.
    - induction l; cbn.
      exact tt.
      destruct a.
      constructor; eauto.
  Defined.

  Theorem of_word_zero_list : forall ft n,
    @Rec.of_word (ArrayF ft n) $0 = repeat (Rec.of_word $0) n.
  Proof.
    induction n; simpl; auto.
    rewrite <- IHn; clear IHn.
    unfold of_word at 1 3.
    rewrite split1_zero.
    rewrite split2_zero.
    reflexivity.
  Qed.

  Theorem of_word_zero_rec : forall ft,
    @Rec.of_word (RecF ft) $0 = (fix reczero (l : list (string * type)) :
      ((fix recdata (t : list (string * type)) : Type :=
                match t with
                | [] => unit
                | (_, ft1) :: t' => (data ft1 * recdata t')%type
                end) l)
      :=
      match l with
      | nil => tt
      | x :: l => let '(_, x) := x in (@Rec.of_word x $0, (reczero l))
      end) ft.
  Proof.
    intros.
    induction ft; cbn.
    auto.
    destruct a; cbn.
    rewrite <- IHft; clear IHft.
    unfold of_word at 1 3.
    rewrite split1_zero.
    rewrite split2_zero.
    reflexivity.
  Qed.

  Theorem of_word_zero_reczero: forall ft,
    Rec.of_word $0 = reczero ft.
  Proof.
    intros.
    einduction ft using type_rect_nest.
    auto.
    rewrite of_word_zero_list.
    rewrite IHt.
    eauto.
    rewrite of_word_zero_rec.
    apply IHt.
    cbn; auto.
    cbn. f_equal; auto.
  Qed.

  Lemma len_add' : forall t n m,
    len (ArrayF t n) + len (ArrayF t m) = len (ArrayF t (n+m)).
  Proof.
    intros.
    simpl.
    nia.
  Qed.

  Lemma combine_0 : forall (v: word 0) n (w: word n),
    combine v w = w.
  Proof.
    intros.
    shatterer.
  Qed.

  Definition len_add {t n m}
    (v:word (len (ArrayF t n) + len (ArrayF t m))) : word (len (ArrayF t (n+m))).
    rewrite len_add' in v.
    exact v.
  Defined.

  Definition len_split {t n m}
    (v:word (len (ArrayF t (n+m)))) : word (len (ArrayF t n) + len (ArrayF t m)).
    rewrite <- len_add' in v.
    exact v.
  Defined.

  Lemma of_word_cons : forall t n (w: word (len (ArrayF t (S n)))),
    of_word w = (of_word (split1 (len t) (n * len t) w)) ::
      (@of_word (ArrayF t n) (split2 (len t) (n * len t) w)).
  Proof.
    intros.
    reflexivity.
  Qed.

  Theorem combine_app' : forall (t:type) (n m:nat) H
    (v : word (len (ArrayF t n))) (w : word (len (ArrayF t m))),
    app (of_word v) (of_word w) = of_word (eq_rect (len (ArrayF t n) + len (ArrayF t m))
      (fun n => word n)
      (combine v w)
      (len (ArrayF t (n+m))) H).
  Proof.
    intros.
    induction n.
    simpl.
    rewrite <- (eq_rect_eq_dec eq_nat_dec).
    rewrite combine_0; reflexivity.
    simpl len in *.
    rewrite of_word_cons.
    simpl.
    erewrite IHn.
    rewrite of_word_cons.

    rewrite <- combine_split with (sz1:=len t) (sz2:=n * len t) (w := v).
    f_equal.
    rewrite split1_combine.
    erewrite combine_assoc.
    rewrite eq_rect_word_match.
    unfold eq_rec.
    rewrite eq_rect_nat_double.
    rewrite eq_rect_combine.
    rewrite split1_combine.
    reflexivity.

    rewrite split2_combine.
    erewrite combine_assoc.
    rewrite eq_rect_word_match.
    unfold eq_rec.
    rewrite eq_rect_nat_double.
    rewrite eq_rect_combine.
    rewrite split2_combine.
    f_equal.

    Grab Existential Variables.
    all: omega.
  Qed.

  Theorem combine_app : forall (t:type) (n m:nat)
    (v : word (len (ArrayF t n))) (w : word (len (ArrayF t m))),
    app (of_word v) (of_word w) = of_word (len_add (combine v w)).
  Proof.
    intros.
    unfold len_add.
    apply combine_app'.
  Qed.

  Theorem cons_to_word : forall (t:type) (n:nat)
    d v,
    @to_word (ArrayF t (S n)) (d :: v) =
      combine (to_word d) (@to_word (ArrayF t n) v).
  Proof.
    intros.
    inversion t; auto.
  Qed.

  Theorem split1_firstn : forall t n m
    (w: word (len (ArrayF t (n+m)))) Heq,
    firstn n (of_word w) =
      of_word (split1 (len (ArrayF t n)) (len (ArrayF t m))
        (eq_rect _ word w _ Heq)).
  Proof.
    intros.
    induction n.
    simpl.
    reflexivity.

    simpl plus in *.
    rewrite of_word_cons.
    simpl.
    rewrite of_word_cons.
    unfold eq_rec_r in *.
    f_equal.
    erewrite split1_iter.
    rewrite eq_rect_word_match.
    rewrite eq_rect_nat_double.
    simpl in *.
    f_equal.
    erewrite eq_rect_split1_eq2.
    f_equal.
    erewrite IHn.
    rewrite eq_rect_split2.
    erewrite split1_split2.
    repeat f_equal.
    rewrite eq_rect_word_match.
    rewrite eq_rect_nat_double.
    unfold eq_rec.
    f_equal.
    apply proof_irrelevance.

    Grab Existential Variables.
    all: try omega.
    simpl.
    nia.
  Qed.

  Theorem split2_skipn : forall t n m
    (w: word (len (ArrayF t (n+m)))) Heq,
    skipn n (of_word w) =
      of_word (split2 (len (ArrayF t n)) (len (ArrayF t m))
       (eq_rect _ word w _ Heq)).
  Proof.
    intros.
    induction n.
    simpl.
    unfold eq_rec_r.
    rewrite <- (eq_rect_eq_dec eq_nat_dec).
    reflexivity.

    simpl plus in *.
    rewrite of_word_cons.
    simpl.

    unfold eq_rec_r in *.
    erewrite IHn.
    rewrite eq_rect_split2.
    erewrite split2_iter.
    rewrite eq_rect_word_match.
    rewrite eq_rect_nat_double.
    unfold eq_rec.
    repeat f_equal.
    apply proof_irrelevance.

    Grab Existential Variables.
    omega.
    simpl; nia.
  Qed.

End Rec.

Notation "r :-> n" := (Rec.recget' n r) (at level 20).
Notation "r :=> n := v" := (Rec.recset' n r v) (at level 80).

Notation "r .⟦ n ⟧" := (Rec.recget' n r) (at level 8).
Notation "r .⟦ n := v ⟧" := (Rec.recset' n r v) (at level 8).

(**
 * This [compute_rec] convtactic allows us to do partial evaluation
 * of [recget] and [recset] so that extracted code does not deal
 * with ASCII string names of fields at runtime.  To use it, define
 * terms with something like:
 *
 *   Definition xx := Eval compute_rec in yy.
 *
 * where [yy] may contain calls to [recget] and [recset].
 *)

Declare Reduction compute_rec :=
  cbv [Rec.recget' Rec.recget Rec.recset' Rec.recset Rec.fieldp
       String.string_dec String.string_rec String.string_rect
       Ascii.ascii_dec Ascii.ascii_rec Ascii.ascii_rect
       sumbool_rec sumbool_rect
       bool_dec bool_rec bool_rect
       eq_rec_r eq_rec eq_rect eq_sym eq_ind_r eq_ind].

Tactic Notation "rec_cbv" "in" hyp(H) :=
  cbv [Rec.recget' Rec.recget Rec.recset' Rec.recset Rec.fieldp
       String.string_dec String.string_rec String.string_rect
       Ascii.ascii_dec Ascii.ascii_rec Ascii.ascii_rect
       sumbool_rec sumbool_rect
       bool_dec bool_rec bool_rect
       eq_rec_r eq_rec eq_rect eq_sym eq_ind_r eq_ind] in H;
  cbn [fst snd] in H.

Tactic Notation "rec_cbv" :=
  cbv [Rec.recget' Rec.recget Rec.recset' Rec.recset Rec.fieldp
       String.string_dec String.string_rec String.string_rect
       Ascii.ascii_dec Ascii.ascii_rec Ascii.ascii_rect
       sumbool_rec sumbool_rect
       bool_dec bool_rec bool_rect
       eq_rec_r eq_rec eq_rect eq_sym eq_ind_r eq_ind];
  cbn [fst snd].

Ltac rec_simpl :=
  repeat match goal with
  | [ H: context [ Rec.recget' ] |- _ ] => rec_cbv in H
  | [ H: context [ Rec.recset' ] |- _ ] => rec_cbv in H
  | [ |- context [ Rec.recget' ] ] => rec_cbv
  | [ |- context [ Rec.recset' ] ] => rec_cbv
  end.


Module Main.

Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

Module Path.

Inductive T (A : Type) (x : A) : A -> Type
  :=
    id : T A x x
.

End Path.

Module Dependent_Function.

Inductive T_
  (A : Type)
  (A_ : A -> A -> Type)
  (B : A -> Type)
  (B_ : forall x : A, forall y : A, A_ x y -> B x -> B y -> Type)
  (f : forall x : A, B x)
  (g : forall x : A, B x)
  : Type
  :=
    value_
      :
          (forall x : A, forall y : A, forall p : A_ x y, B_ x y p (f x) (g y))
        ->
          T_ A A_ B B_ f g
.

Inductive T__
  (A : Type)
  (A_ : A -> A -> Type)
  (A__ : forall x : A, forall y : A, A_ x y -> A_ x y -> Type)
  (B : A -> Type)
  (B_ : forall x : A, forall y : A, A_ x y -> B x -> B y -> Type)
  (
    B__
      :
        forall
          x : A
        ,
        forall
          y : A
        ,
        forall
          p : A_ x y
        ,
        forall
          q : A_ x y
        ,
          A__ x y p q
        ->
        forall
          i : B x
        ,
        forall
          j : B y
        ,
          B_ x y p i j
        ->
          B_ x y q i j
        ->
          Type
  )
  (f : forall x : A, B x)
  (g : forall x : A, B x)
  (x : T_ A A_ B B_ f g)
  (y : T_ A A_ B B_ f g)
  : Type
  :=
    value__
      :
        forall
          x_v : forall x : A, forall y : A, forall p : A_ x y, B_ x y p (f x) (g y)
        ,
        forall
          y_v : forall x : A, forall y : A, forall p : A_ x y, B_ x y p (f x) (g y)
        ,
          (
            forall
              x : A
            ,
            forall
              y : A
            ,
            forall
              p : A_ x y
            ,
            forall
              q : A_ x y
            ,
            forall
              r : A__ x y p q
            ,
              B__ x y p q r (f x) (g y) (x_v x y p) (y_v x y q)
          )
        ->
          T__ A A_ A__ B B_ B__ f g x y
.

End Dependent_Function.

Module Function.

Inductive T_
  (A : Type)
  (A_ : A -> A -> Type)
  (B : Type)
  (B_ : B -> B -> Type)
  (f : A -> B)
  (g : A -> B)
  : Type
  :=
    value_
      :
          (forall x : A, forall y : A, A_ x y -> B_ (f x) (g y))
        ->
          T_ A A_ B B_ f g
.

Inductive T__
  (A : Type)
  (A_ : A -> A -> Type)
  (A__ : forall x : A, forall y : A, A_ x y -> A_ x y -> Type)
  (B : Type)
  (B_ : B -> B -> Type)
  (B__ : forall x : B, forall y : B, B_ x y -> B_ x y -> Type)
  (f : A -> B)
  (g : A -> B)
  (x : T_ A A_ B B_ f g)
  (y : T_ A A_ B B_ f g)
  : Type
  :=
    value__
      :
        forall
          x_v : forall x : A, forall y : A, A_ x y -> B_ (f x) (g y)
        ,
        forall
          y_v : forall x : A, forall y : A, A_ x y -> B_ (f x) (g y)
        ,
          (
            forall
              x : A
            ,
            forall
              y : A
            ,
            forall
              p : A_ x y
            ,
            forall
              q : A_ x y
            ,
              A__ x y p q
            ->
              B__ (f x) (g y) (x_v x y p) (y_v x y q)
          )
        ->
          Path.T (T_ A A_ B B_ f g) x (value_ A A_ B B_ f g x_v)
        ->
          Path.T (T_ A A_ B B_ f g) x (value_ A A_ B B_ f g y_v)
        ->
          T__ A A_ A__ B B_ B__ f g x y
.

Definition compose {A B C : Type} (f : B -> C) (g : A -> B) : A -> C
  := fun x : A => f (g x).

Definition id {A : Type} : A -> A := fun x : A => x.

End Function.

Module TYPE.

Inductive T_
  (R : forall A : Type, A -> A -> Type)
  (
    R_id
      :
        forall
          A : Type
        ,
        forall
          B : Type
        ,
        forall
          f : A -> B
        ,
          Function.T_ A (R A) B (R B) f f
  )
  (
    R_compose
      :
        forall
          A : Type
        ,
        forall
          B : Type
        ,
        forall
          C : Type
        ,
        forall
          f0 : B -> C
        ,
        forall
          f1 : B -> C
        ,
        forall
          g0 : A -> B
        ,
        forall
          g1 : A -> B
        ,
          Function.T_ B (R B) C (R C) f0 f1
        ->
          Function.T_ A (R A) B (R B) g0 g1
        ->
          Function.T_ A (R A) C (R C) (Function.compose f0 g0) (Function.compose f1 g1)
  )
  (A : Type)
  (B : Type)
  : Type
  :=
    value_
      :
        forall
          f : A -> B
        ,
        forall
          g : B -> A
        ,
        forall
          r
            :
              Function.T_ B (R B) B (R B) (Function.compose f g) Function.id
        ,
        forall
          s
            :
              Function.T_ A (R A) A (R A) (Function.compose g f) Function.id
        ,
          Function.T__
            A
            (R A)
            (fun x : A => fun y : A => R (R A x y))
            B
            (R B)
            (fun x : B => fun y : B => R (R B x y))
            (Function.compose f (Function.compose g f))
            f
            (R_compose A B B (Function.compose f g) Function.id f f r (R_id A B f))
            (R_compose A A B f f (Function.compose g f) Function.id (R_id A B f) s)
        ->
          T_ R R_id R_compose A B
.

End TYPE.

Module Name.

Module Tag.

Variant T : Type
  :=
      variable : T
    |
      module : T
.

End Tag.

End Name.

Module Expression.

Inductive T (X : Name.Tag.T -> Type) : Type
  :=
      variable : X Name.Tag.variable -> T X
    |
      abstraction : X Name.Tag.variable -> T X -> T X -> T X
    |
      application : T X -> T X -> T X
    |
      type_type : T X
    |
      type_function : X Name.Tag.variable -> T X -> T X -> T X
.

Inductive T_
  (X : Name.Tag.T -> Type)
  (X_ : forall tag : Name.Tag.T,  X tag -> X tag -> Type)
  (x : T X)
  (y : T X)
  : Type
  :=
      variable_
        :
          forall
            x_v : X Name.Tag.variable
          ,
          forall
            y_v : X Name.Tag.variable
          ,
            X_ Name.Tag.variable x_v y_v
          ->
            Path.T (T X) x (variable X x_v)
          ->
            Path.T (T X) y (variable X y_v)
          ->
            T_ X X_ x y
    |
      application_
        :
          forall
            x_t : T X
          ,
          forall
            x_u : T X
          ,
          forall
            y_t : T X
          ,
          forall
            y_u : T X
          ,
            T_ X X_ x_t y_t
          ->
            T_ X X_ x_u y_u
          ->
            Path.T (T X) x (application X x_t x_u)
          ->
            Path.T (T X) y (application X y_t y_u)
          ->
            T_ X X_ x y
    |
      abstraction_
        :
          forall
            x_x : X Name.Tag.variable
          ,
          forall
            x_A : T X
          ,
          forall
            x_t : T X
          ,
          forall
            y_x : X Name.Tag.variable
          ,
          forall
            y_A : T X
          ,
          forall
            y_t : T X
          ,
            X_ Name.Tag.variable x_x y_x
          ->
            T_ X X_ x_A y_A
          ->
            T_ X X_ x_t y_t
          ->
            Path.T (T X) x (abstraction X x_x x_A x_t)
          ->
            Path.T (T X) y (abstraction X y_x x_A x_t)
          ->
            T_ X X_ x y
    |
      type_type_
        :
            Path.T (T X) x (type_type X)
          ->
            Path.T (T X) y (type_type X)
          ->
            T_ X X_ x y
    |
      type_function_
        :
          forall
            x_x : X Name.Tag.variable
          ,
          forall
            x_A : T X
          ,
          forall
            x_B : T X
          ,
          forall
            y_x : X Name.Tag.variable
          ,
          forall
            y_A : T X
          ,
          forall
            y_B : T X
          ,
            X_ Name.Tag.variable x_x y_x
          ->
            T_ X X_ x_A y_A
          ->
            T_ X X_ x_B y_B
          ->
            Path.T (T X) x (type_function X x_x x_A x_B)
          ->
            Path.T (T X) y (type_function X y_x y_A y_B)
          ->
            T_ X X_ x y
  .

End Expression.

Module MODULE.

Inductive T (X : Name.Tag.T -> Type) : Type
  :=
      use : X Name.Tag.module -> T X -> T X
    |
      define_variable : X Name.Tag.variable -> Expression.T X -> T X -> T X
    |
      define_value : X Name.Tag.variable -> Expression.T X -> Expression.T X -> T X -> T X
    |
      define_module : X Name.Tag.module -> T X -> T X
    |
      eom : T X
.

End MODULE.

Module Bool.

Inductive T : Type
  :=
      true : T
    |
      false : T
.

End Bool.

Module Naming.

Definition Namespace (X : Name.Tag.T -> Type) : Type
  := forall tag : Name.Tag.T, X tag -> Bool.T
.

(*
Axiom collect_name
  (X : Name.Tag.T -> Type)
  (X_ : forall tag : Name.Tag.T, X tag -> X tag -> Bool.T)
  : MODULE.T X -> Namespace X
.
*)

(*
Definition is_valid
  (X : Name.Tag.T -> Type)
  (X_ : forall tag : Name.Tag.T, X tag -> X tag -> Bool.T)
  (X_prefix : forall tag : Name.Tag.T, X Name.Tag.module -> X tag -> X tag)
  : MODULE.T X -> Namespace X -> Bool.T
.
Proof.
  refine
    (
      fix is_valid
        (module : MODULE.T X)
        (namespace : Namespace X)
        {struct module}
        : Bool.T
        := _
    )
  .
  refine
    (
      match module with
          MODULE.use module_i module_n => _
        |
          MODULE.define_variable => _
    )
*)

End Naming.

End Main.


From PlutusCert Require Import
  PlutusIR
  Util
  Congruence
  .
Import NamedTerm.

From Coq Require Import
  Lists.List
  Strings.String.
Import ListNotations.

(*

This pass transforms beta redexes into let non-recs, so that the later inlining
pass has more opportunities for inlining.

Transforms repeated applications (not just repeated β-redexes), e.g.

         $₃
       /  \
     $₂    t₃
   /  \
  $₁   t₂
/  \                    =>      let nonrec x = t₁
λx t₁                                      y = t₂
|                                          z = t₃
λy                              in t_body
|
λz
|
t_body

*)

Inductive lams : Term -> list Term -> list Binding -> Term -> Prop :=

  | Lams_1 : forall t vdecls v ty t_inner arg args,
      lams              t          args                                         vdecls  t_inner ->
      lams (LamAbs v ty t) (arg :: args) (TermBind Strict (VarDecl v ty) arg :: vdecls) t_inner

  | Lams_2 : forall t args,
  (* ~ (exists v ty t', t = LamAbs v ty t') -> *) (* enforces the longest sequence of lambda binders *)
      lams t args [] t
.

(* accumulating param *)
Inductive betas  : Term -> list Term -> list Binding -> Term -> Prop :=

  | Betas_1 : forall s t args bs t_inner,
      betas        s    (t :: args) bs t_inner ->
      betas (Apply s t)       args  bs t_inner

  | Betas_2 : forall t args bs t_inner,
  (* ~ (exists t_f t_x, t = Apply t_f t_x) -> *) (* enforces the longest sequence of arguments *)
      lams t args bs t_inner ->
      betas t args bs t_inner
.

Goal forall v1 v2 τ1 τ2 t t1 t2,
  betas
    (Apply (Apply (LamAbs v1 τ1 (LamAbs v2 τ2 t)) t1) t2) []
    [TermBind Strict (VarDecl v1 τ1) t1; TermBind Strict (VarDecl v2 τ2) t2] t.
intros.
repeat apply Betas_1.
apply Betas_2.
repeat apply Lams_1.
apply Lams_2.
Qed.

Inductive beta : Term -> Term -> Prop :=

  | beta_multi : forall t bs bs' t_inner t_inner',
      betas t [] bs t_inner ->
      Cong_Bindings beta bs bs' ->
      beta t_inner t_inner' ->
      beta t (mk_let NonRec bs t_inner')

  | beta_TyInst_TyAbs : forall ty v k t_body,
      beta
        (TyInst (TyAbs v k t_body) ty)
        (Let NonRec [TypeBind (TyVarDecl v k) ty] t_body)

  | beta_Cong : forall t1 t2,
      Cong beta t1 t2 ->
      beta t1 t2
.


Require Import POCS.

(* Defines programs over a single disk. *)

Module RD.

  Inductive Op : Type -> Type :=
  | Read (a:addr) : Op block
  | Write (a:addr) (b:block) : Op unit
  | DiskSize : Op nat.

  Definition State := disk.

  Inductive step : forall `(op: Op T), Semantics State T :=
  | step_read : forall a r (state: State),
      (forall b, state a = Some b -> r = b) ->
      step (Read a) state r state
  | step_write : forall a b (state: State),
      step (Write a b) state tt (diskUpd state a b)
  | step_disk_size : forall (state: State),
      step (DiskSize) state (size state) state.

  Definition inited (state: State) := True.

  Definition API :=
    {|
      op_sem := @step;
      crash_effect := fun state state' => state' = state;
      init_sem := inited;
    |}.

End RD.


From isla Require Import opsem.

Definition a80010 : isla_trace :=
  WriteReg "R0" [] (RegVal_Base (Val_Bits (BV 64%N 0x3c4%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal15.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))).
Definition lfind_example_2  := ( Succ         (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))))).
Definition lfind_example_3  := ( Succ (Succ (Succ (Succ (Succ (Succ Zero)))))).
Definition lfind_example_4  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_5  := ( Succ (Succ Zero)).
Definition lfind_example_6  := ( Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal15_theorem0_28_lem/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 .


(***************************************************************************
* Generic Environments for Programming Language Metatheory                 *
* Brian Aydemir & Arthur Charguéraud, July 2007, Coq v8.1                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Lib_Tactic List Decidable Metatheory_Var Metatheory_Fresh.

(* ********************************************************************** *)
(** * Definitions of Environments *)

Declare Scope env_scope.

Module Env.

(* ********************************************************************** *)
(** ** Structure and Basic Operations on Environments *)

Section Definitions.

Variable A : Set.
Implicit Types x : var.
Implicit Types a : A.

(** Environments is represented as an associative list. *)

Definition env := list (var * A).

(** Empty environment. *)

Definition empty : env := nil.

(** An environment containing only one binding mapping x to a. *)

Definition single x a := (x,a) :: nil.

(** Concatenation of environments E and F. *)

Definition concat (E F : env) := F ++ E.

(** Comutes the domain of the environment, i.e. the set of vars mapped. *)

Fixpoint dom (E : env) : vars :=
  match E with
  | nil => {}
  | (x, _) :: E' => {{x}} \u (dom E')
  end.

(** [map] applies a function to all the values mapped by the environment. *)

Fixpoint map (f : A -> A) (E : env) {struct E} : env :=
  match E with
  | nil => nil
  | (x, V) :: E' => (x, f V) :: map f E'
  end.

(** [get] locates a binding in an environment. *)

Fixpoint get (x : var) (E : env) {struct E} : option A :=
  match E with
  | nil => None
  | (y,a) :: E' => if eq_var_dec x y then Some a else get x E'
  end.

End Definitions.

(* ********************************************************************** *)
(** ** Notations *)

Arguments empty {A}.

(** [x ~ a] is the notation for a singleton environment mapping x to a. *)

Notation "x ~ a" := (single x a)
  (at level 27, left associativity) : env_scope.

(** [E & F] is the notation for concatenation of E and F. *)

Notation "E & F" := (concat E F)
  (at level 28, left associativity) : env_scope.

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Bind Scope env_scope with env.
Local Open Scope env_scope.

(* ********************************************************************** *)
(** ** Relations on environemnts *)

Section Relations.

Variable A : Set.

(** An environment is well-formed iff it contains no duplicate
  bindings. *)

Inductive ok : env A -> Prop :=
  | ok_empty :
      ok empty
  | ok_push : forall E x a,
      ok E -> x # E -> ok (E & x ~ a).

(** An environment contains a binding from x to a iff the most recent
  binding on x is mapped to a *)

Definition binds x a (E : env A) :=
  get x E = Some a.

(** Proposition capturing the idea that a proposition P holds on all
  values containted in the environment.
  Use In rather than binds for compatibility with fv_in. *)

Definition env_prop (P : A -> Prop) (E : env A) :=
  forall x a, In (x,a) E  -> P a.

(** Inclusion of an environment in another one. *)

Definition extends (E E' : env A) :=
  forall x a, binds x a E -> binds x a E'.

End Relations.

(* ********************************************************************** *)
(** * Properties of Environemnts *)

Hint Constructors ok : core.

Local Open Scope env_scope.

(* ********************************************************************** *)
(** ** Properties of Operations *)

Section OpProperties.
Variable A : Set.
Implicit Types E F : env A.
Implicit Types a b : A.

(** Concatenation with an empty environment is identity. *)

Lemma concat_empty : forall E,
  E & empty = E.
Proof.
  auto.
Qed.

(** Concatenation is associative. *)

Lemma concat_assoc : forall E F G,
  (E & F) & G = E & (F & G).
Proof.
  induction G; simpl; congruence.
Qed.

(** Map commutes with substitution. *)

Lemma map_concat : forall f E F,
  map f (E & F) = (map f E) & (map f F).
Proof.
  induction F as [|(x,a)]; simpl; congruence.
Qed.

(** Interaction of associativity and map. *)

Lemma concat_assoc_map_push : forall f E F y V,
  (E & map f F) & y ~ (f V) = E & (map f (F & y ~ V)).
Proof.
  auto.
Qed.

(** Inversion results. *)

Lemma eq_empty_inv : forall x a E F,
  empty = E & x ~ a & F -> False.
Proof.
  induction F as [|(y,b)]; simpl; discriminate.
Qed.

Lemma eq_push_inv : forall E x a E' x' a',
  E & x ~ a = E' & x' ~ a' -> E = E' /\ x = x' /\ a = a'.
Proof.
  simpl. intros. inversions* H.
Qed.

(** Domain of an empty environment. *)

Lemma dom_empty :
  dom (A:=A) empty = {}.
Proof.
  auto.
Qed.

(** Domain of a singleton environment. *)

Lemma dom_single : forall x a,
  dom (x ~ a) = {{x}}.
Proof.
  simpl. intros. apply union_empty_r.
Qed.

(** Domain of a push is the head variable union the domain of the tail. *)

Lemma dom_push : forall x a E,
  dom (E & x ~ a) = {{x}} \u dom E.
Proof.
  auto.
Qed.

(** Domain of a cons is the head variable union the domain of the tail. *)

Lemma dom_cons : forall x a E,
  dom ((x,a) :: E) = {{x}} \u dom E.
Proof.
  auto.
Qed.

(** Domain of a concatenation is the union of the domains. *)

Lemma dom_concat : forall E F,
  dom (E & F) = dom E \u dom F.
Proof.
  induction F as [|(x,a)]; simpl.
  symmetry. apply union_empty_r.
  rewrite IHF. apply union_comm_assoc.
Qed.

(** Map preserves the domain. *)

Lemma dom_map : forall f E,
  dom (map f E) = dom E.
Proof.
  induction E as [|(x,a)]; simpl; congruence.
Qed.

End OpProperties.

Arguments eq_empty_inv [A x a E F].
Arguments eq_push_inv [A E x a E' x' a'].

(** Simplification tactics *)

Hint Rewrite
  concat_empty
  map_concat
  dom_empty dom_single dom_push dom_cons dom_concat dom_map : rew_env.

Hint Rewrite <- concat_assoc : rew_env.

Tactic Notation "simpl_env" :=
  autorewrite with rew_env in *.

Hint Extern 1 (_ # _) => simpl_env; notin_solve : core.

(** The [env_fix] tactic is used to convert environments
  from [(x,a)::E] to [E & x ~ a]. *)

(* Duplication in first two cases is to work around a Coq bug
   of the change tactic *)

Ltac env_fix_core :=
  let go := try env_fix_core in
  match goal with
  | H: context [(?x,?a)::?E] |- _ =>
     (   (progress (change ((x,a)::E) with (E & x ~ a) in H))
      || (progress (unsimpl (E & x ~ a) in H))   ); go
  | |- context [(?x,?a)::?E] =>
    (   (progress (change ((x,a)::E) with (E & x ~ a)))
      || (progress (unsimpl (E & x ~ a)))  ); go
  |  H: context [@nil ((var * ?A)%type)] |- _ =>
      progress (change (@nil ((var * A)%type)) with (@empty A) in H); go
  | |- context [@nil ((var * ?A)%type)] =>
     progress (change (@nil ((var * A)%type)) with (@empty A)); go
  end.

Ltac env_fix := try env_fix_core.

(* ********************************************************************** *)
(** ** Properties of Well-formedness and Freshness *)

Section OkProperties.
Variable A : Set.
Implicit Types E F : env A.
Implicit Types a b : A.
Hint Constructors ok : core.

(** Inversion for ok on concat *)

Lemma ok_concat_inv : forall E F,
  ok (E & F) -> ok E /\ ok F.
Proof.
  induction F as [|(x,a)]; simpl; env_fix; intros Ok.
  auto*.
  inversions Ok. split. auto*. apply* ok_push.
Qed.

(** Removing bindings preserves ok *)

Lemma ok_remove : forall F E G,
  ok (E & F & G) -> ok (E & G).
Proof.
  induction G as [|(y,a)]; simpl; env_fix; intros Ok.
    induction F as [|(y,a)]; simpl.
      auto.
      inversions* Ok.
    inversions* Ok.
Qed.

(** Mapping values preserves ok *)

Lemma ok_map : forall E F (f : A -> A),
  ok (E & F) -> ok (E & map f F).
intros. induction F as [|(y,a)]; simpl; env_fix.
auto.
rewrite <- concat_assoc in H. inversions* H.
Qed.

(** A binding in the middle of an environment has a var fresh
  from all the bindings before it *)

Lemma fresh_mid : forall E F x a,
  ok (E & x ~ a & F) -> x # E.
Proof.
  induction F; simpl; introv Ok; inversions Ok; env_fix.
    auto.
    inversions H1; env_fix.
     contradictions. fold (@empty A) in H0. apply* eq_empty_inv.
     simpls*.
Qed.

End OkProperties.

(** Automation *)

Hint Resolve fresh_mid ok_map : core.

(* Hint Extern 1 (ok (?E & ?G)) =>
  match goal with H: context [E & ?F & G] |- _ =>
    apply (@ok_remove _ F) end. *)

(* ********************************************************************** *)
(** ** Properties of the binds relation *)

Section BindsProperties.
Variable A : Set.
Implicit Types E F : env A.
Implicit Types a b : A.

Hint Extern 1 (_ \notin _) => notin_solve : core.

(** Binds at head *)

Lemma binds_head : forall x a E,
  binds x a (E & x ~ a).
Proof.
  intros. unfold binds. simpl. case_var*.
Qed.

(** Binds in tail *)

Lemma binds_tail : forall x y a b E,
  x <> y -> binds x a E -> binds x a (E & y ~ b).
Proof.
  intros. unfold binds. simpl. case_var*.
Qed.

(** Binds is functional *)

Lemma binds_func : forall x a b E,
  binds x a E -> binds x b E -> a = b.
Proof.
  unfold binds. introv B1 B2.
  poses H (trans_eq (sym_eq B1) B2).
  inversion* H.
Qed.

(** No binding in an empty environment *)

Lemma binds_empty : forall x a,
  binds x a empty -> False.
Proof.
  introv H. inversions H.
Qed.

(** No binding on x if x is fresh from the environment *)

Lemma binds_fresh : forall x a E,
  binds x a E -> x # E -> False.
Proof.
  unfold binds. induction E as [|(y,b)]; simpl; intros Has Fresh.
  contradictions.
  case_var*. notin_contradiction.
Qed.

(** Binding on x preserved by concatenation if x is fresh
  for the extension *)

Lemma binds_concat_fresh : forall x a E F,
  binds x a E -> x # F -> binds x a (E & F).
Proof.
  unfold binds. induction F as [|(y,b)]; simpl; intros.
  auto. case_var*. notin_contradiction.
Qed.

(** Binding on x preserved by concatenation if the result
  of the concatenation is a well-formed environment *)

Lemma binds_concat_ok : forall x a E F,
  binds x a E -> ok (E & F) -> binds x a (E & F).
Proof.
  unfolds binds. induction F as [|(y,b)]; simpl; intros Map Ok.
  auto.
  inversions Ok. case_var.
    contradictions. apply* (@binds_fresh y a E).
    auto.
Qed.

(** Bindings preserved by pre-catenation *)

Lemma binds_prepend : forall x a E F,
  binds x a F -> binds x a (E & F).
Proof.
  unfold binds. induction F as [|(y,b)]; simpl; intros Map.
  contradictions. case_var*.
Qed.

(** Case analysis on the belonging of a binding to a concatenation *)

Lemma binds_concat_inv : forall x a E F,
  binds x a (E & F) -> (x # F /\ binds x a E) \/ (binds x a F).
Proof.
  unfold binds. induction F as [|(y,b)]; simpl; intros Map.
  left*.
  case_var.
    right*.
    destruct (IHF Map) as [[Fr Map2] | Map2]. left*. right*.
Qed.

(** Interaction of binds and map *)

Lemma binds_map : forall x a f E,
  binds x a E -> binds x (f a) (map f E).
Proof.
  unfold binds. induction E as [|(y,b)]; simpl; intros Map.
  contradictions. case_var*. inversions* Map.
Qed.

(** Retreive the binding on x from an environment [E & (x~a) & F] *)

Lemma binds_mid : forall x a E F,
  ok (E & x ~ a & F) -> binds x a (E & x ~ a & F).
Proof.
  unfold binds. induction F as [|(y,b)]; simpl; intros Ok.
  case_var*.
  inversions Ok. case_var.
    simpl_env. notin_contradiction.
    auto.
Qed.

(** The binding on x in the environment [E & (x~a) & F] can only
   be bound to a if that environment is well-formed *)

Lemma binds_mid_eq : forall z a b E F,
  binds z a (E & z ~ b & F) -> ok (E & z ~ b & F) -> a = b.
Proof.
  unfold binds. induction F as [|(y,c)]; simpl; intros Map Ok.
  case_var*. inversions* Map.
  inversions Ok. case_var.
    inversions Ok. simpl_env. notin_contradiction.
    auto.
Qed.

(** Inversion on a binding in an atomic environment *)

Lemma binds_single_inv : forall x y a b,
  binds x a (y ~ b) -> x = y /\ a = b.
Proof.
  unfold binds. simpl. intros. case_var.
   inversions* H.
   contradictions.
Qed.

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the binds_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma binds_weaken : forall x a E F G,
  binds x a (E & G) -> ok (E & F & G) ->
  binds x a (E & F & G).
Proof.
  unfold binds. induction G as [|(y,b)]; simpl; intros Map Ok.
  apply* binds_concat_ok.
  inversions Ok. case_var*.
Qed.

(* Whether bindings are or not in the context is decidable *)

Lemma binds_dec : forall E x a,
  (forall a1 a2 : A, {a1 = a2} + {a1 <> a2}) ->
  decidable (binds x a E).
Proof.
  introv Dec. remember (get x E) as B. symmetry in HeqB.
  unfold binds. destruct B as [a'|].
  destruct (Dec a a'). subst.
    left*.
    right*. intros H. congruence.
  right*. intros H. congruence.
Qed.

End BindsProperties.

Arguments binds_concat_inv [A x a E F].

Hint Resolve binds_head binds_tail : core.

(* ********************************************************************** *)
(** ** Properties of environment inclusion *)

Section ExtendsProperties.
Variable A : Set.
Implicit Types E F : env A.

Lemma extends_self : forall E,
  extends E E.
Proof.
  introz. auto.
Qed.

Lemma extends_push : forall E x a,
  x # E -> extends E (E & x ~ a).
Proof.
  introz. apply* binds_tail.
  destruct (x0 == x).
    subst. contradictions. apply* binds_fresh.
    auto.
Qed.

Lemma binds_inj : forall E x a b,
  binds x a E -> binds x b E -> a = b.
Proof.
  unfold binds. intros. congruence.
Qed.

Lemma extends_binds : forall E x a,
  binds x a E -> extends E (E & x ~ a).
Proof.
  introz. unfolds binds. simpl. case_var. congruence. auto.
Qed.

End ExtendsProperties.

Hint Resolve extends_self extends_push extends_binds : core.

(* ********************************************************************** *)
(** ** Iteration of pushing bindings in the environment *)

Section IterPush.
Variable A : Set.
Implicit Types E F : env A.

Definition iter_push (xs : list var) (vs : list A) :=
  rev (combine xs vs).

Lemma iter_push_nil : forall xs,
  iter_push xs nil = nil.
Proof.
  induction xs; simpl*.
Qed.

Lemma iter_push_cons : forall x (v : A) xs vs,
  iter_push (x::xs) (v::vs) = (x ~ v) & (iter_push xs vs).
Proof.
  auto*.
Qed.

Lemma ok_concat_iter_push : forall xs E (Us : list A),
  ok E ->
  fresh (dom E) (length xs) xs ->
  ok (E & iter_push xs Us).
Proof.
  induction xs; simpl; intros. auto.
  destruct H0. destruct Us; simpls. auto.
  rewrite iter_push_cons. rewrite* <- concat_assoc.
Qed.

End IterPush.

Hint Resolve ok_concat_iter_push : core.

Section Fv_in.

(* ********************************************************************** *)
(** ** Gathering free variables of the values contained in an
  environment *)

Variables (A : Set) (fv : A -> vars).

(** Computing free variables contained in an environment. *)

Fixpoint fv_in (E : env A) : vars :=
  match E with
  | nil => {}
  | (x,a)::E' => fv a \u fv_in E'
  end.

(** Specification of the above function in terms of [bind]. *)

Lemma fv_in_spec : forall E, env_prop (fun a => fv a << fv_in E) E.
Proof.
  induction E; intro; simpl; intros. elim H.
  destruct H; intro; intros.
    subst. auto with sets.
  destruct a.
  puts (IHE _ _ H).
  auto with sets.
Qed.

End Fv_in.

(* ********************************************************************** *)
(** ** Tactics *)

Opaque binds.

(** [binds_get H as EQ] produces from an hypothesis [H] of
  the form [binds x a (E & x ~ b & F)] the equality [EQ: a = b]. *)

Tactic Notation "binds_get" constr(H) "as" ident(EQ) :=
  match type of H with binds ?z ?a (?E & ?x ~ ?b & ?F) =>
    let K := fresh "K" in assert (K : ok (E & x ~ b & F));
    [ auto | poses EQ (@binds_mid_eq _ z a b E F H K); clear K ] end.

(** [binds_get H] expects an hypothesis [H] of the form
  [binds x a (E & x ~ b & F)] and substitute [a] for [b] in the goal. *)

Tactic Notation "binds_get" constr(H) :=
  let EQ := fresh in binds_get H as EQ;
  try match type of EQ with
  | ?f _ = ?f _ => inversions EQ; clear EQ
  | ?x = ?y => subst x end.

(** [binds_single H] derives from an hypothesis [H] of the form
  [binds x a (y ~ b)] the equalities [x = y] and [a = b], then
  it substitutes [x] for [y] in the goal or deduce a contradiction
  if [x <> y] can be found in the context. *)

Ltac binds_single H :=
  match type of H with binds ?x ?a (?y ~ ?b) =>
    destruct (binds_single_inv H);
    try discriminate; try subst y;
    try match goal with N: ?x <> ?x |- _ =>
      contradictions; apply N; reflexivity end end.

(** [binds_case H as B1 B2] derives from an hypothesis [H] of the form
  [binds x a (E & F)] two subcases: [B1: binds x a E] (with a freshness
  condition [x # F]) and [B2: binds x a F]. *)

Tactic Notation "binds_case" constr(H) "as" ident(B1) ident(B2) :=
   let Fr := fresh "Fr" in
   destruct (binds_concat_inv H) as [[Fr B1] | B2].

(** [binds_case H] makes a case analysis on an hypothesis [H] of the form
  [binds x a E] where E can be constructed using concatenation and
  singletons. It calls [binds_single] when reaching a singleton. *)

Ltac binds_cases H :=
  let go B := clear H;
    first [ binds_single B | binds_cases B | idtac ] in
  let B1 := fresh "B" in let B2 := fresh "B" in
  binds_case H as B1 B2; simpl_env; [ go B1 | go B2 ].

(** Automation *)

Hint Resolve
  binds_concat_fresh binds_concat_ok
  binds_prepend binds_map : core.

(* ********************************************************************** *)
(** ** Other tactics (syntactical sugar for tactics) *)

(** Tactic to apply an induction hypothesis modulo a rewrite of
  the associativity of the environment necessary to handle the
  inductive rules dealing with binders. [apply_ih_bind] is in
  fact just a syntactical sugar for [do_rew concat_assoc (eapply H)]
  which in turns stands for
  [rewrite concat_assoc; eapply H; rewrite <- concat_assoc]. *)

Tactic Notation "apply_ih_bind" constr(H) :=
  do_rew concat_assoc (eapply H).

Tactic Notation "apply_ih_bind" "*" constr(H) :=
  do_rew* concat_assoc (eapply H).

(** Similar as the above, except in the case where there
  is also a map function, so we need to use [concat_assoc_map_push]
  for rewriting. *)

Tactic Notation "apply_ih_map_bind" constr(H) :=
  do_rew concat_assoc_map_push (eapply H).

Tactic Notation "apply_ih_map_bind" "*" constr(H) :=
  do_rew* concat_assoc_map_push (eapply H).

(** [apply_empty] applies a lemma of the form "forall E:env, P E"
    in the particular case where E is empty. The tricky step is
    the simplification of "P empty" before the "apply" tactic is
    called, and this is necessary for Coq to recognize that the
    lemma indeed applies. *)

Tactic Notation "apply_empty" constr(lemma) :=
  let H := fresh in poses H (@lemma empty);
  simpl in H; eapply H; env_fix; clear H.

Tactic Notation "apply_empty" "*" constr(lemma) :=
  apply_empty lemma; auto*.

End Env.