(*Here we give the denotational semantics for inductive
  predicates and prove that they are the least fixpoint
  that makes all the constructors true*)
Require Import Common.
Require Import Syntax.
Require Import Types.
Require Import Typing.
Require Import Substitution. (*for bnd_t - move? *)
Require Import IndTypes.
Require Import Semantics.
Require Import Denotational.
Require Import Alpha.
Require Import Hlist.
Require Import FunctionalExtensionality.
Require Import Coq.Logic.Eqdep_dec.
Set Bullet Behavior "Strict Subproofs".

Section IndPropRep.

Context {sigma: sig} {gamma: context}
  (gamma_valid: valid_context sigma gamma)
  (pd: pi_dom).

Variable all_unif: forall m,
  mut_in_ctx m gamma ->
  uniform m.

Section Def.

(*First, define interpretations*)

(*An interpretation where we substitute p with P*)

Definition interp_with_P (pi: pi_funpred gamma_valid pd) (p: predsym)
  (P: forall srts,
    arg_list (domain (dom_aux pd)) (sym_sigma_args p srts) -> bool) :
  pi_funpred gamma_valid pd :=
  {|
  funs := funs gamma_valid pd pi;
  preds :=
    fun pr : predsym =>
    match predsym_eq_dec p pr with
    | left Heq =>
        match Heq with
        | eq_refl => P
        end
    | _ => preds gamma_valid pd pi pr
    end;
  constrs := constrs gamma_valid pd pi
|}.

(*For the list of predsyms, we need to search through the list
  to apply the correct pred. The dependent types make this
  complicated, so we use a separate function*)
Fixpoint find_apply_pred (pi: pi_funpred gamma_valid pd)
(ps: list predsym)
(*Our props are an hlist, where we have a Pi for each pi
of type (srts -> arg_list pi srts -> bool)*)
(Ps: hlist (fun (p: predsym) => forall srts,
  arg_list (domain (dom_aux pd))
  (sym_sigma_args p srts) -> bool) ps) (p: predsym) :
  (forall srts : list sort,
    arg_list (domain (dom_aux pd))
      (sym_sigma_args p srts) -> bool) :=
  (match ps as ps' return
  (hlist (fun p : predsym =>
    forall srts : list sort,
    arg_list (domain (dom_aux pd))
      (sym_sigma_args p srts) -> bool) ps') ->
    forall srts : list sort,
      arg_list (domain (dom_aux pd))
        (sym_sigma_args p srts) -> bool with
  (*Underneath the depednent types, this is quite
    simple: iterate through the list, compare for equality
    and if so, apply the correct Pi function*)
  | nil => fun _ => (preds gamma_valid pd pi p)
  | p' :: ptl =>  fun Hp =>
    match (predsym_eq_dec p p') with
    | left Heq => ltac:(rewrite Heq; exact (hlist_hd Hp))
    | right _ => (find_apply_pred pi ptl (hlist_tl Hp) p)
    end
  end) Ps.

(*Do the same for a list of predsyms*)
Definition interp_with_Ps (pi: pi_funpred gamma_valid pd)
  (ps: list predsym)
  (*Our props are an hlist, where we have a Pi for each pi
  of type (srts -> arg_list pi srts -> bool)*)
  (Ps: hlist (fun (p: predsym) => forall srts,
    arg_list (domain (dom_aux pd))
    (sym_sigma_args p srts) -> bool) ps) :
  pi_funpred gamma_valid pd :=
  {|
  funs := funs gamma_valid pd pi;
  preds := find_apply_pred pi ps Ps;
  constrs := constrs gamma_valid pd pi
|}.

Lemma find_apply_pred_in (pf: pi_funpred gamma_valid pd)
  (ps: list predsym)
  (Ps: hlist
  (fun p' : predsym =>
   forall srts : list sort,
   arg_list (domain (dom_aux pd)) (sym_sigma_args p' srts) -> bool)
  ps)
  (p: predsym)
  (Hinp: in_bool predsym_eq_dec p ps) :
  find_apply_pred pf ps Ps p =
  get_hlist_elt predsym_eq_dec Ps p Hinp.
Proof.
  induction ps; simpl.
  - inversion Hinp.
  - revert Hinp. simpl.
    destruct (predsym_eq_dec p a); subst; auto.
Qed.

Lemma find_apply_pred_notin (pf: pi_funpred gamma_valid pd)
(ps: list predsym)
(Ps: hlist
(fun p' : predsym =>
 forall srts : list sort,
 arg_list (domain (dom_aux pd)) (sym_sigma_args p' srts) -> bool)
ps)
(p: predsym) :
~ In p ps ->
find_apply_pred pf ps Ps p = preds gamma_valid pd pf p.
Proof.
  induction ps; simpl; auto.
  intros Hnot. destruct (predsym_eq_dec p a); subst; auto.
  exfalso. apply Hnot; auto.
Qed.

Lemma interp_with_Ps_single (pi: pi_funpred gamma_valid pd)
  (p: predsym)
  (Ps: hlist (fun (p:predsym) => forall srts,
    arg_list (domain (dom_aux pd))
    (sym_sigma_args p srts) -> bool) [p]) :
  interp_with_Ps pi [p] Ps =
  interp_with_P pi p (hlist_hd Ps).
Proof.
  unfold interp_with_Ps. simpl.
  unfold interp_with_P. f_equal.
  apply functional_extensionality_dep. intros p'.
  destruct (predsym_eq_dec p' p).
  - subst. destruct (predsym_eq_dec p p); simpl; [|contradiction].
    assert (e = eq_refl) by (apply UIP_dec; apply predsym_eq_dec).
    rewrite H. reflexivity.
  - destruct (predsym_eq_dec p p'); subst; auto.
    contradiction.
Qed.

Definition iter_and (l: list Prop) : Prop :=
  fold_right and True l.

Lemma prove_iter_and (ps: list Prop):
  (forall x, In x ps -> x) <-> iter_and ps.
Proof.
  induction ps; simpl; split; intros; auto.
  - destruct H0.
  - split. apply H. left. reflexivity.
    rewrite <- IHps. intros x Hinx. apply H. right. assumption.
  - destruct H. destruct H0; subst; auto.
    apply IHps; auto.
Qed.

Fixpoint dep_map {A B: Type} {P: A -> Prop} (f: forall x, P x -> B)
  (l: list A) (Hall: Forall P l) : list B :=
  match l as l' return Forall P l' -> list B with
  | nil => fun _ => nil
  | x :: tl => fun Hforall => f x (Forall_inv Hforall) ::
    dep_map f tl (Forall_inv_tail Hforall)
  end Hall.

Lemma dep_map_in {A B: Type} {P: A -> Prop} (f: forall x, P x -> B)
  (l: list A) (Hall: Forall P l) (x: B):
  In x (dep_map f l Hall) ->
  exists y H, In y l /\ f y H = x.
Proof.
  revert Hall. induction l; simpl; intros. destruct H.
  inversion Hall; subst.
  destruct H.
  - subst. exists a. exists (Forall_inv Hall). split; auto.
  - specialize (IHl _ H). destruct IHl as [y [Hy [Hiny Hxy]]].
    exists y. exists Hy. split; auto.
Qed.

Lemma in_dep_map {A B: Type} {P: A -> Prop} (f: forall x, P x -> B)
  (l: list A) (Hall: Forall P l) (x: A):
  In x l ->
  exists H,
    In (f x H) (dep_map f l Hall).
Proof.
  revert Hall. induction l; simpl; intros. destruct H.
  inversion Hall; subst. destruct H; subst.
  - exists (Forall_inv Hall). left. reflexivity.
  - specialize (IHl (Forall_inv_tail Hall) H).
    destruct IHl as [Hx Hinx]. exists Hx. right. assumption.
Qed.

Lemma dep_map_irrel {A B: Type} {P: A -> Prop} (f: forall x, P x -> B)
  (l: list A) (Hall1 Hall2: Forall P l):
  (forall x H1 H2, f x H1 = f x H2) ->
  dep_map f l Hall1 = dep_map f l Hall2.
Proof.
  intros Hirrel.
  revert Hall1 Hall2.
  induction l; intros; simpl; auto.
  erewrite IHl. f_equal. apply Hirrel.
Qed.

(*Since inductive predicates can be mutually recursive, we need
  a list of predsyms and formula lists. This makes the dependent
  types tricky, since we need a (P: forall srts, arg_list srts -> bool)
  for each such predsym*)

Definition indpred_rep (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt)
  (indpred : list (predsym * list formula))
  (Hform: Forall (Forall (valid_formula sigma)) (map snd indpred))
  (p: predsym)
  (Hin: in_bool predsym_eq_dec p (map fst indpred))
  (srts: list sort)
  (a: arg_list (domain (dom_aux pd))
  (sym_sigma_args p srts)) : bool :=
  (*Our props are an hlist, where we have a Pi for each pi
  of type (srts -> arg_list pi srts -> bool)*)
  all_dec ((forall (Ps: hlist (fun (p': predsym) =>
    (forall (srts: list sort),
    arg_list (domain (dom_aux pd))
    (sym_sigma_args p' srts) -> bool)) (map fst indpred)),
    (*The precondition is the conjunction of all of the
      inductive hypotheses from the list of formulas, with
      each recursive instance using the appropriate Pi*)
    ((fix build_indpred (l: list (list formula))
      (Hl: Forall (Forall (valid_formula sigma)) l) : Prop :=
      match l as l' return
        Forall (Forall (valid_formula sigma)) l' -> Prop
      with
      | nil => fun _ => True
      | fs :: ftl => fun Hall =>
        iter_and (map is_true (dep_map (@formula_rep _ _ gamma_valid pd all_unif
          vt (interp_with_Ps pf _ Ps) vv)
           fs (Forall_inv Hall))) /\
          build_indpred ftl (Forall_inv_tail Hall)
      end Hl) _ Hform)
       ->
      (*All of this together implies Pi srts a, for the
        i corresponding to p*)
      (get_hlist_elt predsym_eq_dec Ps p Hin) srts a)).

(*The version for non-mutual-recursion is a lot simpler*)
Definition indpred_rep_single (pf: pi_funpred gamma_valid pd)
(vt: val_typevar) (vv: val_vars pd vt) (p: predsym)
  (fs: list formula) (Hform: Forall (valid_formula sigma) fs) (srts: list sort)
  (a: arg_list (domain (dom_aux pd))
  (sym_sigma_args p srts)) : bool :=
  all_dec
  (forall (P: forall (srts: list sort),
    arg_list (domain (dom_aux pd))
    (sym_sigma_args p srts) -> bool),
    iter_and (map is_true (dep_map (@formula_rep _ _ gamma_valid
      pd  all_unif vt (interp_with_P pf p P) vv)
      fs Hform)) -> P srts a).

(*We prove these equivalent in the single case
  (it makes things easier when we don't need hlists)*)

Definition Forall_single {A: Type} {P: A -> Prop} {x: list A}
  (Hform: Forall P x) :
  Forall (Forall P) [x] :=
  Forall_cons _  Hform (@Forall_nil (list A) (Forall P)).

Lemma in_triv {A} p (fs: list A): is_true (in_bool predsym_eq_dec p (map fst [(p, fs)])).
Proof.
  simpl. destruct (predsym_eq_dec); auto.
Defined.

(*Prove equivalence*)
Lemma indpred_rep_single_equiv (pf: pi_funpred gamma_valid pd)
(vt: val_typevar) (vv: val_vars pd vt) (p: predsym)
(fs: list formula) (Hform: Forall (valid_formula sigma) fs) (srts: list sort)
(a: arg_list (domain (dom_aux pd))
(sym_sigma_args p srts)) :
  indpred_rep_single pf vt vv p fs Hform srts a =
  indpred_rep pf vt vv [(p, fs)] (Forall_single Hform) p (in_triv p fs) srts a.
Proof.
  unfold indpred_rep_single.
  unfold indpred_rep. simpl.
  apply all_dec_eq.
  split; intros.
  - generalize dependent (in_triv p fs). simpl.
    destruct (predsym_eq_dec p p); simpl; auto.
    intros _. unfold eq_rect_r, eq_rect.
    assert (e = eq_refl) by (apply UIP_dec; apply predsym_eq_dec).
    rewrite H1. simpl.
    specialize (H (hlist_hd Ps)).
    apply H. destruct H0 as [Hand _].
    revert Hand.
    rewrite (interp_with_Ps_single pf p Ps); intros Hand.
    erewrite dep_map_irrel. apply Hand. intros.
    apply fmla_rep_irrel.
  - revert H. generalize dependent (in_triv p fs); simpl.
    destruct (predsym_eq_dec p p); simpl; auto.
    intros _ Hmult.
    specialize (Hmult (HL_cons (fun p' : predsym =>
    forall srts : list sort,
    arg_list (domain (dom_aux pd)) (sym_sigma_args p' srts) -> bool)
    p nil P (@HL_nil _ _))).
    revert Hmult. simpl. unfold eq_rect_r, eq_rect.
    assert (e = eq_refl). apply UIP_dec. apply predsym_eq_dec.
    rewrite H. simpl. intros Hmult.
    apply Hmult; clear Hmult. split; auto.
    rewrite (interp_with_Ps_single pf p _). simpl.
    erewrite dep_map_irrel. apply H0.
    intros. apply fmla_rep_irrel.
Qed.

End Def.

(*Now we prove that [indpred_rep] is the
  least predicate that satifies the constructors. *)
(*We must show the following:
  1. For all constructors, f, [[f]]_i holds, where i maps
      each predicate symbol p in ps to [indpred_rep ps p].
  2. Given any other Ps such that the constructors hold
    under i, where i maps p in ps to (nth i Ps),
    then (indpred_rep p ps x) -> (nth i Ps x)
  The second part is very easy. The first is very hard.*)

(*First, some helpful lemmas*)

(*One of the complications is that the [build_indpred]
  function is difficult to work with. This is a more
  useful form *)
  Lemma build_indpred_iff (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt) (ps: list predsym)
  (Ps: hlist
  (fun p' : predsym =>
   forall srts : list sort,
   arg_list (domain (dom_aux pd)) (sym_sigma_args p' srts) -> bool)
  ps)
  (fs: list (list formula))
  (Hform: Forall (Forall (valid_formula sigma)) fs):
  ((fix build_indpred
    (l : list (list formula))
    (Hl : Forall (Forall (valid_formula sigma)) l) {struct l} :
      Prop :=
    match
      l as l'
      return (Forall (Forall (valid_formula sigma)) l' -> Prop)
    with
    | [] =>
        fun _ : Forall (Forall (valid_formula sigma)) [] => True
    | fs :: ftl =>
        fun
          Hall : Forall (Forall (valid_formula sigma))
                  (fs :: ftl) =>
        iter_and
          (map is_true
            (dep_map
                (formula_rep gamma_valid pd all_unif vt
                  (interp_with_Ps pf ps Ps) vv)
                fs (Forall_inv Hall))) /\
        build_indpred ftl (Forall_inv_tail Hall)
    end Hl) fs Hform) <->
    (forall (f: list formula)
    (Hallf: Forall (valid_formula sigma) f)
    (Hinf: In f fs),
    iter_and
    (map is_true
        (dep_map
          (formula_rep gamma_valid pd all_unif vt
              (interp_with_Ps pf ps Ps) vv) f Hallf))).
Proof.
  revert Hform.
  induction fs; simpl; intros; split; intros; auto.
  - destruct Hinf.
  - destruct H as [Hhd Htl].
    destruct Hinf; subst.
    + erewrite dep_map_irrel. apply Hhd.
      intros. apply fmla_rep_irrel.
    + eapply IHfs. apply Htl. auto.
  - split.
    + erewrite dep_map_irrel. apply H. left; auto.
      intros. apply fmla_rep_irrel.
    + eapply IHfs. intros. apply H. right; auto.
  Unshelve.
  inversion Hform; subst. auto.
Qed.

Scheme Minimality for valid_ind_form Sort Prop.

Section LeastPred.

(*We prove the second part (the "least predicate" part)
  first, since it is easy*)
Theorem indpred_least_pred (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt)
  (ps: list (predsym * list formula))
  (Hform: Forall (Forall (valid_formula sigma)) (map snd ps)):
  forall (Ps: hlist
    (fun p' : predsym =>
    forall srts : list sort,
    arg_list (domain (dom_aux pd)) (sym_sigma_args p' srts) -> bool)
    (map fst ps)),
  (*If P holds of all of the constructors*)
  (forall (fs : list formula) (Hform : Forall (valid_formula sigma) fs),
    In fs (map snd ps) ->
      iter_and (map is_true (dep_map
        (formula_rep gamma_valid pd all_unif vt
        (interp_with_Ps pf (map fst ps) Ps) vv) fs Hform))) ->
(*Then indpred_rep p fs x -> P x*)
  forall (p: predsym) (Hinp: in_bool predsym_eq_dec p (map fst ps))
    (srts: list sort)
    (a: arg_list (domain (dom_aux pd))
    (sym_sigma_args p srts)),
    indpred_rep pf vt vv ps Hform p Hinp srts a ->
    get_hlist_elt predsym_eq_dec Ps p Hinp srts a.
Proof.
  intros Ps Hand p Hinp srts a.
  unfold indpred_rep.
  rewrite simpl_all_dec. intros.
  apply H.
  rewrite build_indpred_iff.
  auto.
Qed.

(*On the other hand, the first part is hard (showing that [indpred_rep]
  holds of all constructors). Here is an approach to show it:
  1. Prove that any constructor is equivalent to one where we
    have a bunch of forall quantifiers, followed by a bunch
    of let statements, followed by a chain of impliciations
    ending in indpred_rep p fs x for some x
  2. From this, unfold the definition of indpred_rep,
    and we eventually have to prove that, for each of the
    "and" formulas in the implication, if [[f]] is true
    when ps map to [indpred_rep ps], then [[f]] is true
    when ps map to Ps for any Ps. This is true if f is
    strictly positive, showing why this condition is crucial.

  Step 1 requires a lot of steps
  1. define variable substitution and prove correctness
  2. define a function to substitute all bound variables
    to new, unique values (alpha equivalence)
  3. define a transformation into the (forall _, let _, and f_i -> f)
    form, and prove that preserves the semantics.
    Then, prove that this both ends in P srts x for
    [valid_ind_forms] and that the [f_i]'s are strictly
    positive
  4. Prove the crucial lemma that [[f]]_[ps->indpred_rep ps] ->
    [[f]]_[ps->Ps] for any Ps if ps occur strictly
    positively in f
  5. Prove the main theorem*)

(*We did steps 1 and 2 in Denotational.v (TODO). We start with
  step 3*)

Definition tup_1 {A B C D: Type} (x: A * B * C * D) :=
  match x with
  | (a, _, _, _) => a
  end.
Definition tup_2 {A B C D: Type} (x: A * B * C * D) :=
  match x with
  | (_, b, _, _) => b
  end.
Definition tup_3 {A B C D: Type} (x: A * B * C * D) :=
  match x with
  | (_, _, c, _) => c
  end.
Definition tup_4 {A B C D: Type} (x: A * B * C * D) :=
  match x with
  | (_, _, _, d) => d
  end.

(*The decomposition*)
Fixpoint indpred_decomp (f: formula) :
  (list vsymbol * list (vsymbol * term) * list formula * formula) :=
  match f with
  | Fquant Tforall x f1 =>
    let t := indpred_decomp f1 in
    (x :: tup_1 t, tup_2 t, tup_3 t, tup_4 t)
  | Fbinop Timplies f1 f2 =>
    let t := indpred_decomp f2 in
    (tup_1 t, tup_2 t, f1 :: tup_3 t, tup_4 t)
  | Flet t1 v f1 =>
    let t := indpred_decomp f1 in
    (tup_1 t, (v, t1) :: tup_2 t, tup_3 t, tup_4 t)
  | _ => (nil, nil, nil, f)
  end.

(*Now we prove that for [valid_ind_form] formulas with
  well-formed bound variables, [indpred_decomp] produces
  an equivalent formula when interpreted.*)
  Ltac split_all :=
  repeat match goal with
  | H: ?P /\ ?Q |- _ => destruct H
  | |- ?P /\ ?Q => split
  end.

(*A few results about [indpred_decomp]*)

(*First, validity results we need - this proof is very easy*)
Lemma indpred_decomp_valid (f: formula) (Hval: valid_formula sigma f) :
  Forall (fun x : string * vty => valid_type sigma (snd x)) (tup_1 (indpred_decomp f)) /\
  Forall (fun x : string * vty * term => term_has_type sigma (snd x) (snd (fst x)))
    (tup_2 (indpred_decomp f)) /\
  Forall (valid_formula sigma) (tup_3 (indpred_decomp f)) /\
  valid_formula sigma (tup_4 (indpred_decomp f)).
Proof.
  revert Hval.
  apply (term_formula_ind) with(P1:=fun _ => True) (P2:= fun f =>
    valid_formula sigma f ->
    Forall (fun x : string * vty => valid_type sigma (snd x)) (tup_1 (indpred_decomp f)) /\
    Forall (fun x : string * vty * term => term_has_type sigma (snd x) (snd (fst x)))
      (tup_2 (indpred_decomp f)) /\
    Forall (valid_formula sigma) (tup_3 (indpred_decomp f)) /\
    valid_formula sigma (tup_4 (indpred_decomp f))); simpl; auto; intros.
  - destruct q; simpl; auto.
    inversion H0; subst. specialize (H H6).
    split_all; auto.
  - destruct b; simpl; auto.
    inversion H1; subst. specialize (H H5).
    specialize (H0 H7). split_all; auto.
  - inversion H1; subst.
    specialize (H0 H7). split_all; auto.
  - apply (Tconst (ConstInt 0)).
Qed.

Ltac triv_fls :=
  split_all; intros;
    match goal with | H: False |- _ => destruct H end.

Lemma indpred_decomp_bound (f: formula) :
  (forall x, In x (tup_1 (indpred_decomp f)) -> In x (bnd_f f)) /\
  (forall x, In x (tup_2 (indpred_decomp f)) -> In (fst x) (bnd_f f)).
Proof.
  apply (term_formula_ind) with(P1:=fun _ => True) (P2:= fun f =>
  (forall x : vsymbol, In x (tup_1 (indpred_decomp f)) -> In x (bnd_f f)) /\
  (forall x : vsymbol * term,
   In x (tup_2 (indpred_decomp f)) -> In (fst x) (bnd_f f))); simpl; auto; intros;
   try solve[triv_fls].
  - destruct q; simpl;[|triv_fls].
    split_all; intros.
    + destruct H1; subst. left; auto. right. apply H. auto.
    + apply H0 in H1. right; auto.
  - destruct b; simpl; try triv_fls. split; intros; simpl;
    apply in_or_app; right; apply H0; auto.
  - split_all; intros. right. apply in_or_app. right. apply H0; auto.
    destruct H2; subst. left; auto. right. apply in_or_app. right.
    apply H1. auto.
  - apply (Tconst (ConstInt 0)).
Qed.

Lemma indpred_decomp_wf (f: formula) (Hwf: fmla_wf f):
  (forall x, ~ (In x (tup_1 (indpred_decomp f)) /\
    In x (map fst (tup_2 (indpred_decomp f))))).
Proof.
  revert Hwf.
  apply (term_formula_ind) with(P1:=fun _ => True) (P2:= fun f =>
  fmla_wf f ->
  forall x : vsymbol,
  ~
  (In x (tup_1 (indpred_decomp f)) /\ In x (map fst (tup_2 (indpred_decomp f)))));
  auto; simpl; auto; intros; try solve[intro C; triv_fls].
  - destruct q; simpl; [|intro C; triv_fls].
    intro C. split_all.
    destruct H1; subst.
    + specialize (H (wf_quant _ _ _ H0)).
      unfold fmla_wf in H0.
      simpl in H0. split_all. inversion H0; subst.
      rewrite in_map_iff in H2. destruct H2 as [y [Hy Hiny]].
      assert (In (fst y) (bnd_f f0)).
      apply indpred_decomp_bound. auto. subst. contradiction.
    + apply (H (wf_quant _ _ _ H0) x); auto.
  - destruct b; simpl; intro C; try triv_fls.
    apply (H0 (proj2 (wf_binop _ _ _ H1)) x). auto.
  - specialize (H0 (wf_let _ _ _ H1)).
    intro C. split_all.
    destruct H3; subst.
    + unfold fmla_wf in H1. simpl in H1. split_all. inversion H1; subst.
      apply H6. apply in_or_app. right. apply indpred_decomp_bound; auto.
    + apply (H0 x); auto.
  - apply (Tconst (ConstInt 0)).
Qed.

(*How we transform this decomposition into a formula*)
Definition indpred_transform (f: formula) : formula :=
  (fforalls (tup_1 (indpred_decomp f))
      (iter_flet (tup_2 (indpred_decomp f))
        (Fbinop Timplies
          (iter_fand (tup_3 (indpred_decomp f)))
          (tup_4 (indpred_decomp f))))).

Lemma indpred_transform_valid (f: formula) (Hval: valid_formula sigma f) :
  valid_formula sigma (indpred_transform f).
Proof.
  unfold indpred_transform.
  apply fforalls_valid;[|apply indpred_decomp_valid; auto].
  apply iter_flet_valid; [| apply indpred_decomp_valid; auto].
  constructor; [|apply indpred_decomp_valid; auto].
  apply iter_fand_valid; auto.
  apply indpred_decomp_valid; auto.
Qed.

(*Now, we prove that any formula which is valid and whose bound
  variables are well-formed is equivalent to the one formed
  by [indpred_decomp]*)
Lemma indpred_decomp_equiv (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: @val_vars sigma pd vt)
  (f: formula) (Hval: valid_formula sigma f)
  (Hwf: fmla_wf f) :
  formula_rep gamma_valid pd all_unif vt pf vv f Hval =
  formula_rep gamma_valid pd all_unif vt pf vv
    (indpred_transform f) (indpred_transform_valid f Hval).
Proof.
  revert vv.
  generalize dependent (indpred_transform_valid f Hval).
  (*TODO: we need a better way to do induction with formulas*)
  revert Hval Hwf.
  apply term_formula_ind with(P1:=fun _ => True)
  (P2:= fun f => forall Hval : valid_formula sigma f,
  fmla_wf f -> forall (v : valid_formula sigma (indpred_transform f))
  (vv : val_vars pd vt),
  formula_rep gamma_valid pd all_unif vt pf vv f Hval =
  formula_rep gamma_valid pd all_unif vt pf vv (indpred_transform f) v);
  unfold indpred_transform; simpl; auto; intros; try solve[apply true_impl].
  - destruct q; simpl; auto; [|apply true_impl].
    simpl in v0.
    simpl_rep_full. apply all_dec_eq.
    split; intros Hall d.
    + rewrite <- H with (Hval:=(valid_quant_inj Hval)).
      apply (Hall d).
      apply wf_quant in H0; auto.
    + erewrite H. apply (Hall d).
      apply wf_quant in H0; auto.
  - destruct b; try solve[apply true_impl].
    simpl.
    simpl in v.
    (*We need to know that we can push a let and a quantifier
      across an implication. This is why we need the wf assumption*)
    simpl_rep_full.
    rewrite bool_of_binop_impl.
    assert (Hval1 : valid_formula sigma
    (fforalls (tup_1 (indpred_decomp f2))
       (iter_flet (tup_2 (indpred_decomp f2))
          (Fbinop Timplies (iter_fand (tup_3 (indpred_decomp f2)))
             (tup_4 (indpred_decomp f2)))))). {
      apply fforalls_valid_inj in v. split_all.
      apply fforalls_valid; auto.
      apply iter_flet_valid_inj in H2. split_all.
      apply iter_flet_valid; auto.
      inversion H2; subst.
      constructor; auto.
      inversion H8; subst. auto.
    }
    rewrite H0 with(v:=Hval1); [| apply (wf_binop _ _ _ H1)].
    assert (Hval2: valid_formula sigma
    (fforalls (tup_1 (indpred_decomp f2))
       (iter_flet (tup_2 (indpred_decomp f2))
          (Fbinop Timplies f1 (Fbinop Timplies
            (iter_fand (tup_3 (indpred_decomp f2)))
            (tup_4 (indpred_decomp f2))))))). {
      inversion Hval; subst.
      apply fforalls_valid_inj in Hval1. split_all.
      apply iter_flet_valid_inj in H2. split_all.
      inversion H2; subst.
      apply fforalls_valid; auto.
      apply iter_flet_valid; auto.
      constructor; auto.
    }
    rewrite and_impl_bound with(Hval2:=Hval2).
    assert (Hval3: valid_formula sigma (Fbinop Timplies f1
      (fforalls (tup_1 (indpred_decomp f2))
      (iter_flet (tup_2 (indpred_decomp f2))
            (Fbinop Timplies (iter_fand (tup_3 (indpred_decomp f2)))
                (tup_4 (indpred_decomp f2))))))). {
      apply fforalls_valid_inj in Hval2; split_all.
      apply iter_flet_valid_inj in H2; split_all.
      inversion H2; subst. constructor; auto.
    }
    rewrite (distr_impl_let_forall _ _ _ vt pf vv f1) with(Hval2:=Hval3).
    + simpl_rep_full. rewrite bool_of_binop_impl.
      apply all_dec_eq. split; intros;
      erewrite fmla_rep_irrel;
      apply H2; erewrite fmla_rep_irrel; apply H3.
    + (*Now, prove that everything in tup_1 is a bound variable in formula*)
      intros. intro C. split_all.
      unfold fmla_wf in H1. split_all. apply (H4 x).
      split_all; simpl; auto. apply union_elts. left; auto.
      apply in_or_app. right. apply indpred_decomp_bound; auto.
    + intros x C. unfold fmla_wf in H1. split_all.
      apply (H4 (fst x)). split_all.
      simpl. apply union_elts. left; auto.
      simpl. apply in_or_app. right. apply indpred_decomp_bound; auto.
  - (*On to let case*)
    simpl_rep_full.
    assert (Hval1: valid_formula sigma
    (fforalls (tup_1 (indpred_decomp f0))
       (iter_flet (tup_2 (indpred_decomp f0))
          (Fbinop Timplies (iter_fand (tup_3 (indpred_decomp f0)))
             (tup_4 (indpred_decomp f0)))))). {
      apply fforalls_valid_inj in v0; split_all.
      inversion H2; subst.
      apply fforalls_valid; auto.
    }
    rewrite H0 with(v:=Hval1); [| apply (wf_let _ _ _ H1)].
    (*We showed that we can push a let through a fforalls as long
      as v is not in any of those bound variables*)
    assert (Hval2: valid_formula sigma (Flet tm v
    (fforalls (tup_1 (indpred_decomp f0))
       (iter_flet (tup_2 (indpred_decomp f0))
          (Fbinop Timplies (iter_fand (tup_3 (indpred_decomp f0)))
             (tup_4 (indpred_decomp f0))))))). {
      apply fforalls_valid_inj in v0; split_all.
      inversion H2; subst.
      constructor; auto.
    }
    erewrite distr_let_foralls with(Hval2:=Hval2).
    simpl_rep_full.
    erewrite term_rep_irrel.
    erewrite fmla_rep_irrel. reflexivity.
    (*These contradict wf*)
    intro C.
    assert (In v (bnd_f f0)). {
      apply indpred_decomp_bound; auto.
    }
    unfold fmla_wf in H1. split_all. simpl in H1. inversion H1; subst.
    apply H6. apply in_or_app; right; auto.
    intros y Hy C.
    assert (In y (bnd_f f0)). {
      apply indpred_decomp_bound; auto.
    }
    unfold fmla_wf in H1. split_all. simpl in H3.
    apply (H3 y).
    split_all; auto.
    apply union_elts. left; auto.
    right. apply in_or_app. right; auto.
  - apply (Tconst (ConstInt 0)).
Qed.

(*Finally, we need to reason about the last part of the formula.
  We show that, for [valid_ind_form]s, this is Fpred p tys tms, for
  tys and tms given by the following function *)
Fixpoint get_indprop_args (f: formula) : (list vty * list term) :=
  match f with
  | Fpred p tys tms => (tys, tms)
  | Fquant Tforall x f1 => get_indprop_args f1
  | Flet t x f1 => get_indprop_args f1
  | Fbinop Timplies f1 f2 => get_indprop_args f2
  | _ => (nil ,nil)
  end.

Lemma ind_form_decomp (p: predsym) (f: formula)
  (Hval: valid_ind_form p f) :
  (tup_4 (indpred_decomp f)) = Fpred p (fst (get_indprop_args f))
    (snd (get_indprop_args f)).
Proof.
  induction Hval; simpl; auto.
Qed.

(** Results based on Positivity/Strict Positivity *)

Lemma positive_fforalls (ps: list predsym) (q: list vsymbol) (f: formula):
  ind_positive ps f <->
  ind_positive ps (fforalls q f).
Proof.
  split; intros.
  - induction q; intros; simpl; auto. constructor; auto.
  - induction q; simpl; auto; intros. inversion H; subst; auto.
Qed.

Lemma positive_iter_flet (ps: list predsym) (l: list (vsymbol * term))
  (f: formula):
  ind_positive ps (iter_flet l f) <->
  (Forall (fun x => (forall p, In p ps -> negb (predsym_in_term p (snd x)))) l) /\
  ind_positive ps f.
Proof.
  split; intros.
  - induction l; simpl; auto.
    simpl in H. inversion H; subst.
    specialize (IHl H4). split_all; auto.
  - induction l; simpl; auto. apply H.
    split_all. inversion H; subst.
    constructor; auto.
Qed.

(*First, if p appears in f positively, then p
  appears in [indpred_transform] positively *)
Lemma indpred_transform_positive (ps: list predsym) (f: formula)
  (Hpos: ind_positive ps f):
  ind_positive ps (indpred_transform f).
Proof.
  unfold indpred_transform.
  apply positive_fforalls.
  (*lets are harder because we need to know doesnt appear in term*)
  induction Hpos; simpl; auto.
  - constructor. constructor. auto. constructor; auto.
  - constructor; auto.
  - rewrite positive_iter_flet in IHHpos.
    rewrite positive_iter_flet. split_all; auto.
    clear H0.
    inversion H1; subst.
    constructor; auto.
    apply ISP_and; auto.
Qed.

Lemma strict_pos_and (ps: list predsym) (f1 f2: formula):
  ind_strictly_positive ps (Fbinop Tand f1 f2) ->
  ind_strictly_positive ps f1 /\
  ind_strictly_positive ps f2.
Proof.
  intros. inversion H; subst.
  - simpl in H0.
    split; apply ISP_notin; intros p Hinp; specialize (H0 p Hinp);
    rewrite negb_orb in H0; apply andb_true_iff in H0; apply H0.
  - auto.
Qed.

Lemma iter_and_strict_pos (ps: list predsym) (fs: list formula):
  ind_strictly_positive ps (iter_fand fs) ->
  forall f, In f fs ->
  ind_strictly_positive ps f.
Proof.
  induction fs; simpl; auto.
  - intros; triv_fls.
  - intros.
    apply strict_pos_and in H. split_all.
    destruct H0; subst; auto.
Qed.

(*From this, we prove that p appears in the "and" part
  strictly positively*)
Lemma indpred_decomp_and_strict_pos (ps: list predsym) (f: formula)
  (Hpos: ind_positive ps f):
  (forall f1, In f1 (tup_3 (indpred_decomp f)) -> ind_strictly_positive ps f1).
Proof.
  intros.
  apply indpred_transform_positive in Hpos.
  unfold indpred_transform in Hpos.
  apply positive_fforalls in Hpos.
  apply positive_iter_flet in Hpos.
  split_all.
  inversion H1; subst.
  apply (iter_and_strict_pos _ _ H4); auto.
Qed.

(*We also conclude that p appears in the last part
  positively*)
Lemma indpred_decomp_last_pos (ps: list predsym) (f: formula)
  (Hpos: ind_positive ps f):
  ind_positive ps (tup_4 (indpred_decomp f)).
Proof.
  apply indpred_transform_positive in Hpos.
  unfold indpred_transform in Hpos.
  apply positive_fforalls in Hpos.
  apply positive_iter_flet in Hpos.
  split_all. inversion H0; subst. auto.
Qed.

(*We also need the fact that everything in (tup_2) does not include
  anything in ps*)
Lemma indpred_decomp_let_notin (ps: list predsym) (f: formula)
  (Hpos: ind_positive ps f):
  Forall (fun x =>
    forall (p: predsym), In p ps ->
      negb (predsym_in_term p (snd x))) (tup_2 (indpred_decomp f)).
Proof.
  apply indpred_transform_positive in Hpos.
  unfold indpred_transform in Hpos.
  apply positive_fforalls in Hpos.
  apply positive_iter_flet in Hpos.
  split_all; auto.
Qed.

(*We need the following: since all of the constructor
  formulas are closed, they are equivalent under any valuation;
  accordingly, so is [indpred_rep]*)
Lemma constrs_val_eq (pf: pi_funpred gamma_valid pd)
(vt: val_typevar) (v1 v2: val_vars pd vt)
(fs: list formula)
(Hform: Forall (valid_formula sigma) fs)
(Hclosed: Forall closed_formula fs) :
  iter_and (map is_true (dep_map
    (formula_rep gamma_valid pd
      all_unif vt pf v1) fs Hform)) =
  iter_and (map is_true (dep_map
    (formula_rep gamma_valid pd
      all_unif vt pf v2) fs Hform)).
Proof.
  f_equal. f_equal.
  revert Hform.
  induction fs; simpl; auto.
  intros. inversion Hform; subst. inversion Hclosed; subst.
  f_equal; auto.
  apply fmla_closed_val; auto.
Qed.

Lemma indpred_rep_val_eq (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (v1 v2: val_vars pd vt)
  (ps: list (predsym * list formula))
  (Hform: Forall (Forall (valid_formula sigma)) (map snd ps))
  (Hclosed: Forall (Forall closed_formula) (map snd ps))
  (p: predsym) (Hinp: in_bool predsym_eq_dec p (map fst ps)):
  indpred_rep pf vt v1 ps Hform p Hinp =
  indpred_rep pf vt v2 ps Hform p Hinp.
Proof.
  unfold indpred_rep.
  repeat(apply functional_extensionality_dep; intros).
  apply all_dec_eq.
  split; intros Hand Ps; specialize (Hand Ps);
  rewrite build_indpred_iff; intros Hallconstrs;
  apply Hand; rewrite build_indpred_iff;
  intros f Hallf Hinf; specialize (Hallconstrs f Hallf Hinf);
  erewrite constrs_val_eq; try apply Hallconstrs;
  rewrite Forall_forall in Hclosed; apply Hclosed; assumption.
Qed.

(*Now we prove our key intermediate lemma that we need:
  suppose f is a formula in which p appears strictly positiviely,
  then [[f]]_(p->indpred_rep p) implies [[f]]_(p->P) for any P*)
Lemma strict_pos_impred_implies_P' (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt)
  (ps: list (predsym * (list formula)))
  (f: formula)
  (Hvalf: valid_formula sigma f)
  (Hpos: ind_strictly_positive (map fst ps) f)
  (Hform: Forall (Forall (valid_formula sigma)) (map snd ps))
  (Hclosed: Forall (Forall closed_formula) (map snd ps))
  (Hindpred: forall (p : predsym)
    (Hinp : in_bool predsym_eq_dec p (map fst ps)),
    preds gamma_valid pd pf p =
    indpred_rep pf vt vv ps Hform p Hinp)
  :
  forall (Ps: hlist
    (fun p' : predsym =>
    forall srts : list sort,
    arg_list (domain (dom_aux pd)) (sym_sigma_args p' srts) -> bool)
    (map fst ps)),
  (*If P holds of all of the constructors*)
  (forall (fs: list formula) (Hform: Forall (valid_formula sigma) fs),
    In fs (map snd ps) ->
  iter_and (map is_true (dep_map
    (formula_rep gamma_valid pd all_unif vt
      (interp_with_Ps pf (map fst ps) Ps) vv) fs Hform))) ->
  (*Then [[f]]_(p->indpred_rep p) implies [[f]]_(p->P)*)
  formula_rep gamma_valid pd all_unif vt pf vv f Hvalf ->
  formula_rep gamma_valid pd all_unif vt (interp_with_Ps pf (map fst ps) Ps) vv f Hvalf.
Proof.
  intros Ps HandPs.
  generalize dependent vv.
  induction Hpos; simpl; intros vv Hindpred HandP; auto;
  simpl_rep_full.
  - intros Hrep. erewrite fmla_predsym_agree. apply Hrep.
    all: auto.
    intros p' Hinp'.
    unfold interp_with_Ps; simpl.
    (*Show that p' not in (map fst ps)*)
    destruct (in_bool_spec predsym_eq_dec p' (map fst ps));
    [|apply find_apply_pred_notin; auto].
    specialize (H _ i). rewrite Hinp' in H. inversion H.
  - (*Show arg lists are the same: because P cannot appear
      in list by strict positivity*)
    assert ((pred_arg_list pd vt p vs ts
    (term_rep gamma_valid pd all_unif vt pf vv) Hvalf) =
    (pred_arg_list pd vt p vs ts
    (term_rep gamma_valid pd all_unif vt
    (interp_with_Ps pf (map fst ps) Ps) vv) Hvalf)). {
      apply get_arg_list_eq.
      rewrite Forall_forall. intros.
      rewrite term_rep_irrel with(Hty2:=Hty2).
      apply term_predsym_agree; simpl; auto.
      intros p' Hinp'. symmetry.
      destruct (in_bool_spec predsym_eq_dec p' (map fst ps));
      [|apply find_apply_pred_notin; auto].
      specialize (H0 _ _ H1 i). rewrite Hinp' in H0. inversion H0.
    }
    rewrite <- H1. rewrite Hindpred with(Hinp:=(In_in_bool predsym_eq_dec _ _ H)).
    rewrite find_apply_pred_in with(Hinp:=(In_in_bool predsym_eq_dec _ _ H)).
    apply indpred_least_pred. auto.
  - rewrite !bool_of_binop_impl, !simpl_all_dec.
    intros Hinpl Hval.
    apply IHHpos; auto.
    apply Hinpl.
    (*Now we use the fact that P is not in f1*)
    rewrite (fmla_predsym_agree) with(p2:=(interp_with_Ps pf (map fst ps) Ps)); auto.
    intros p' Hinp'.
    simpl. symmetry.
    destruct (in_bool_spec predsym_eq_dec p' (map fst ps));
    [|apply find_apply_pred_notin; auto].
    specialize (H _ i). rewrite Hinp' in H. inversion H.
  - destruct q;simpl_rep_full.
    + rewrite !simpl_all_dec; intros Hall d; specialize (Hall d).
      apply IHHpos; auto.
      (*Use closed fmla assumptions*)
      * intros p Hinp.
        erewrite indpred_rep_val_eq; auto.
      * intros. erewrite constrs_val_eq; auto.
        rewrite Forall_forall in Hclosed. apply Hclosed; auto.
    + rewrite !simpl_all_dec; intros [d Hex]; exists d.
      apply IHHpos; auto.
      * intros p Hinp.
        erewrite indpred_rep_val_eq; auto.
      * intros. erewrite constrs_val_eq; auto.
        rewrite Forall_forall in Hclosed. apply Hclosed; auto.
  - unfold is_true; rewrite !andb_true_iff;
    intros [Hf1 Hf2].
    split; [apply IHHpos1 | apply IHHpos2]; auto.
  - unfold is_true; rewrite !orb_true_iff;
    intros [Hf1 | Hf2];
    [left; apply IHHpos1 | right; apply IHHpos2]; auto.
  - intros Hf. apply IHHpos; auto.
    + intros p Hinp. erewrite indpred_rep_val_eq; auto.
    + intros. erewrite constrs_val_eq; auto.
      rewrite Forall_forall in Hclosed. apply Hclosed; auto.
    + (*Need fact that p doesn't appear in let term*)
      erewrite term_predsym_agree. apply Hf. all: auto.
      intros p' Hinp'. simpl.
      destruct (in_bool_spec predsym_eq_dec p' (map fst ps));
      [|apply find_apply_pred_notin; auto].
      specialize (H _ i). rewrite Hinp' in H. inversion H.
  - (*First, know that [[f1]] eq in both cases because P cannot be
      present*)
    assert (Hf1: formula_rep gamma_valid pd all_unif vt pf vv f1
    (proj1 (valid_if_inj Hvalf)) =
    formula_rep gamma_valid pd all_unif vt (interp_with_Ps pf (map fst ps) Ps) vv f1
    (proj1 (valid_if_inj Hvalf))). {
      apply fmla_predsym_agree; auto; simpl; intros p' Hinp'.
      symmetry.
      destruct (in_bool_spec predsym_eq_dec p' (map fst ps));
      [|apply find_apply_pred_notin; auto].
      specialize (H _ i). rewrite Hinp' in H. inversion H.
    }
    rewrite <- Hf1.
    destruct (formula_rep gamma_valid pd all_unif vt pf vv f1
    (proj1 (valid_if_inj Hvalf)));
    [apply IHHpos1 | apply IHHpos2]; auto.
  - (*Hmm, this is the hardest one - need rewrite lemma for match*)
    (*Here, we need a nested induction*)
    iter_match_gen Hvalf Htms Hps Hvalf.
    induction pats; simpl; auto.
    intros. destruct a as [fh ph]. revert H2.
    (*Show that [term_rep] is equal because P cannot appear*)
    assert (Hteq:
    (term_rep gamma_valid pd all_unif vt pf vv t ty Hvalf) =
    (term_rep gamma_valid pd all_unif vt (interp_with_Ps pf (map fst ps) Ps) vv t ty
       Hvalf)). {
      apply term_predsym_agree; auto. intros p' Hinp'; simpl.
      symmetry.
      destruct (in_bool_spec predsym_eq_dec p' (map fst ps));
      [|apply find_apply_pred_notin; auto].
      specialize (H _ i). rewrite Hinp' in H. inversion H.
    }
    rewrite <- Hteq at 1.
    destruct (match_val_single gamma_valid pd all_unif vt ty fh (Forall_inv Hps)
    (term_rep gamma_valid pd all_unif vt pf vv t ty Hvalf)) eqn : Hm.
    + (*First case follows from original IH*)
      apply H1; simpl; auto.
      * intros p Hinp. erewrite indpred_rep_val_eq; auto.
      * intros. erewrite constrs_val_eq; auto.
        rewrite Forall_forall in Hclosed. apply Hclosed; auto.
    + (*From nested IH*)
      apply IHpats; auto.
      * intros h Hinf. apply H0. right; auto.
      * intros. apply H1; auto. right; auto.
Qed.

(*TODO: move*)
(*If some pred P does not appear in any terms for [substi_multi_let],
  then valuations are equal no matter what P is*)

Lemma substi_mult_notin_eq (pf1 pf2: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt) (l: list (vsymbol * term))
  (ps: list predsym) Hall
  (Hallnotin: Forall (fun x => (forall p, In p ps ->
    negb (predsym_in_term p (snd x)))) l) :
  (forall p, ~ In p ps -> (preds gamma_valid pd pf1 p) = (preds gamma_valid pd pf2 p)) ->
  (forall f, funs gamma_valid pd pf1 f = funs gamma_valid pd pf2 f) ->
  substi_multi_let gamma_valid pd all_unif vt pf1 vv l Hall =
  substi_multi_let gamma_valid pd all_unif vt pf2 vv l Hall.
Proof.
  revert Hall vv.
  induction l; simpl; auto; intros.
  inversion Hallnotin; subst.
  destruct a.
  assert (substi pd vt vv v
  (term_rep gamma_valid pd all_unif vt pf1 vv t (snd v) (Forall_inv Hall)) =
  (substi pd vt vv v
     (term_rep gamma_valid pd all_unif vt pf2 vv t (snd v) (Forall_inv Hall)))). {
    unfold substi. apply functional_extensionality_dep; intros; simpl.
    destruct (vsymbol_eq_dec x v); subst; auto.
    unfold eq_rec_r, eq_rec, eq_rect. simpl.
    apply term_predsym_agree; auto.
    intros p Hinp.
    apply H. intro Hinp'.
    simpl in H3. apply H3 in Hinp'.
    rewrite Hinp in Hinp'. inversion Hinp'.
  }
  rewrite H1.
  apply IHl; auto.
Qed.

(*Finally, we prove the main theorem*)
(*TODO: prove version with recursive instance of Ps
  (need lemma that we can assign Ps anything and it doesn't
  matter - not hard to show)*)
Theorem indpred_constrs_true
  (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt)
  (indpred: list (predsym * list formula))
  (Hform: Forall (Forall (valid_formula sigma)) (map snd indpred))
  (Hvalind: Forall (fun t => Forall (valid_ind_form (fst t)) (snd t))
    indpred)
  (Hpos: Forall (Forall (ind_positive (map fst indpred)))
    (map snd indpred))
  (Hclosed: Forall (Forall closed_formula) (map snd indpred))
  (Hindpred: forall p
    (Hinp: in_bool predsym_eq_dec p (map fst indpred)),
    preds gamma_valid pd pf p =
    indpred_rep pf vt vv indpred Hform p Hinp) :
  (forall (f: formula) (Hvalf: valid_formula sigma f),
    In f (concat (map snd indpred)) ->
    formula_rep gamma_valid pd all_unif vt pf vv f Hvalf).
Proof.
  intros f Hvalf Hinf.
  rewrite in_concat in Hinf.
  destruct Hinf as [fs [Hinfs Hinf]].
  assert (Hinfs':=Hinfs).
  rewrite in_map_iff in Hinfs.
  destruct Hinfs as [[p fs'] [Hfst Hinfs]]; simpl in Hfst; subst.
  (*Part 1: work with alpha conversion to get wf*)
  rewrite a_convert_f_rep.
  assert (Hvalindf: valid_ind_form p f). {
    rewrite Forall_forall in Hvalind.
    specialize (Hvalind (p, fs) Hinfs). simpl in Hvalind.
    rewrite Forall_forall in Hvalind. apply Hvalind; auto.
  }
  assert (Hposf: ind_positive (map fst indpred) f). {
    rewrite Forall_forall in Hpos.
    specialize (Hpos fs Hinfs').
    rewrite Forall_forall in Hpos.
    apply Hpos; auto.
  }
  assert (Hvalinda:=(a_convert_f_valid_ind_form p f Hvalindf)).
  assert (Hwfa:=(a_convert_f_wf f)).
  assert (Hposa:=(a_convert_f_pos (map fst indpred) f Hposf)).
  (*Part 2: Work with [indpred_transform] *)
  rewrite indpred_decomp_equiv; auto.
  assert (Hvaldec:=(indpred_transform_valid _ (a_convert_f_valid _ Hvalf))).
  (*Then we can unfold manually*)
  unfold indpred_transform in *.
  assert (A:=Hvaldec).
  apply fforalls_valid_inj in A.
  destruct A as [Hval1 Halltup1].
  rewrite fmla_rep_irrel with
    (Hval2:= (fforalls_valid (tup_1 (indpred_decomp (a_convert_f f))) _ Hval1 Halltup1)).
  rewrite fforalls_val. rewrite simpl_all_dec. intros h.
  assert (A:=Hval1).
  apply iter_flet_valid_inj in A.
  destruct A as [Hval2 Halltup2].
  rewrite (fmla_rep_irrel) with(Hval2:=(iter_flet_valid _ _ Hval2 Halltup2)).
  rewrite iter_flet_val. simpl_rep_full.
  rewrite bool_of_binop_impl, simpl_all_dec.
  intros Hconstrs.
  (*Might need lemma about equality of fmlas*)
  assert (Hval3: valid_formula sigma (Fpred p (fst (get_indprop_args (a_convert_f f))) (snd (get_indprop_args (a_convert_f f))))). {
    rewrite <- ind_form_decomp; auto.
    inversion Hval2; subst; auto.
  }
  rewrite fmla_rewrite with(Hval2:=Hval3); [|apply ind_form_decomp; auto].
  simpl_rep_full.
  assert (Hinp: In p (map fst indpred)). {
    rewrite in_map_iff. exists (p, fs); auto.
  }
  assert (Hinp': in_bool predsym_eq_dec p (map fst indpred)) by
    (apply In_in_bool; auto).
  rewrite Hindpred with(Hinp:=Hinp').
  (*Now we can unfold the definition of [indpred_rep_single]*)
  unfold indpred_rep.
  rewrite simpl_all_dec; intros Ps Hallconstrs.
   (*We need 2 things from this (unwieldy) definition:
    that all constructors in fs are true under p->P interp,
    and that f is true. Obviously the second follows*)
  assert (Hallfs: Forall (valid_formula sigma) fs). {
    clear -Hform Hinfs'.
    rewrite Forall_forall in Hform; auto.
  }
  rewrite build_indpred_iff in Hallconstrs.
  assert (Hconstrsfs :=(Hallconstrs fs Hallfs Hinfs')).
  (*Now, we need to know that this constructor (f) is true
    under p->P interp*)
  assert (Hformf: formula_rep gamma_valid pd
    all_unif vt (interp_with_Ps pf (map fst indpred) Ps) vv f Hvalf). {
      rewrite <- prove_iter_and in Hconstrsfs.
      apply Hconstrsfs.
      rewrite in_map_iff. exists (formula_rep gamma_valid pd
        all_unif vt (interp_with_Ps pf (map fst indpred) Ps) vv f Hvalf).
      split; auto.
      assert (Hex:=(in_dep_map
        (formula_rep gamma_valid pd  all_unif vt
          (interp_with_Ps pf (map fst indpred) Ps) vv) _ Hallfs _ Hinf)).
      destruct Hex as [Hval4 Hinf'].
      erewrite fmla_rep_irrel. apply Hinf'.
  }
  (*Now we repeat the process again (alpha, [indpred_transform, etc])*)
  revert Hformf.
  rewrite a_convert_f_rep, indpred_decomp_equiv; auto.
  unfold indpred_transform.
  rewrite fmla_rep_irrel with
    (Hval2:= (fforalls_valid _ _ Hval1 Halltup1)).
  rewrite fforalls_val, simpl_all_dec.
  intros. specialize (Hformf h).
  revert Hformf.
  rewrite (fmla_rep_irrel) with(Hval2:=(iter_flet_valid _ _ Hval2 Halltup2)).
  rewrite iter_flet_val; simpl_rep_full.
  rewrite bool_of_binop_impl, simpl_all_dec.
  rewrite fmla_rewrite with(f1:=(tup_4 _))(Hval2:=Hval3); [|apply ind_form_decomp; auto].
  simpl_rep_full.
  (*Here we need to deal with [find_apply_pred] - need to show
    it is equal to [get_hlist_elt]*)
  rewrite find_apply_pred_in with(Hinp:=Hinp').
  intros.
  (*Need this in multiple places*)
  assert ((substi_multi_let gamma_valid pd all_unif vt (interp_with_Ps pf (map fst indpred) Ps)
    (substi_mult pd vt vv (tup_1 (indpred_decomp (a_convert_f f))) h)
    (tup_2 (indpred_decomp (a_convert_f f))) Halltup2) =
    (substi_multi_let gamma_valid pd all_unif vt pf
     (substi_mult pd vt vv (tup_1 (indpred_decomp (a_convert_f f))) h)
     (tup_2 (indpred_decomp (a_convert_f f))) Halltup2)). {
      apply substi_mult_notin_eq with(ps:=map fst indpred); simpl; auto.
      - apply indpred_decomp_let_notin with(ps:=map fst indpred); auto.
      - apply find_apply_pred_notin.
  }
  (*Now, we need to show that the arguments to P are actually the same
    because these terms cannot involve P*)
  (*Ugly but oh well*)
  match goal with | H: _ -> is_true (get_hlist_elt _ _ _ _ ?y ?z)
    |- is_true (get_hlist_elt _ _ _ _ ?y ?a) => assert (z = a) end.
  - apply get_arg_list_eq.
    rewrite Forall_forall. intros x Hinx ty Hty1 Hty2.
    rewrite H.
    rewrite term_rep_irrel with(Hty2:=Hty2).
    apply term_predsym_agree; auto.
    intros p1 Hinp1.
    unfold interp_with_Ps; simpl.
    destruct (in_bool_spec predsym_eq_dec p1 (map fst indpred));
    [|rewrite find_apply_pred_notin; auto].
    (*Use fact that p1 not in x*)
    assert (Hindt: ind_positive (map fst indpred) (tup_4 (indpred_decomp (a_convert_f f)))).
      apply indpred_decomp_last_pos; auto.
    rewrite ind_form_decomp with(p:=p) in Hindt; auto.
    inversion Hindt; subst.
    specialize (H4 p1 x Hinx i).
    rewrite Hinp1 in H4. inversion H4.
  - rewrite <- H0. apply Hformf.
    clear H0 Hformf.
    rewrite H. clear H.
    remember (substi_multi_let gamma_valid pd all_unif vt pf
    (substi_mult pd vt vv (tup_1 (indpred_decomp (a_convert_f f))) h)
    (tup_2 (indpred_decomp (a_convert_f f))) Halltup2) as vv'.
    clear Heqvv'.
    (*Now, we just need to prove that the [iter_and] of all of
      these constructors is true, when we interpre p with P
      instead of [pf]. Here we will use the strict positivity
      lemma *)
    rewrite iter_fand_rep.
    rewrite iter_fand_rep in Hconstrs.
    intros f' Hvalf' Hinf'.
    specialize (Hconstrs f' Hvalf' Hinf').
    revert Hconstrs.
    (*Nearly done, need full version of lemma*)
    eapply strict_pos_impred_implies_P' with(ps:=indpred)(Hform:=Hform); auto.
    + apply (indpred_decomp_and_strict_pos _ _ Hposa); auto.
    + intros p1 Hinp1.
      erewrite indpred_rep_val_eq; auto.
    + intros. erewrite constrs_val_eq; auto.
      rewrite Forall_forall in Hclosed. apply Hclosed; auto.
Qed.

End LeastPred.

(*We prove simpler versions for the non-mutual case, since
  working with hlists is awkward *)
Section Single.

Theorem indpred_constrs_true_single
  (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt)
  (p: predsym) (fs: list formula)
  (Hform: Forall (valid_formula sigma) fs)
  (Hvalind: Forall (fun f => valid_ind_form p f) fs)
  (Hpos: Forall (fun f => ind_positive [p] f) fs)
  (Hclosed: Forall closed_formula fs)
  (Hindpred: (preds gamma_valid pd pf) p =
    indpred_rep_single pf vt vv p fs Hform) :
  (forall (f: formula) (Hvalf: valid_formula sigma f),
    In f fs ->
    formula_rep gamma_valid pd all_unif vt pf vv f Hvalf).
Proof.
  intros.
  apply (indpred_constrs_true) with(indpred:=[(p, fs)])(Hform:=(Forall_single Hform));
  simpl; auto.
  - intros p' Hinp'.
    assert (p = p'). { destruct (predsym_eq_dec p' p); subst; auto.
      inversion Hinp'. }
    subst.
    assert (Hinp' = (in_triv p' [(p', fs)])). {
      apply UIP_dec. apply Bool.bool_dec.
    }
    rewrite H0.
    repeat (apply functional_extensionality_dep; intros).
    rewrite <- indpred_rep_single_equiv, Hindpred.
    reflexivity.
  - rewrite app_nil_r. auto.
Qed.

Theorem indpred_least_pred_single (pf: pi_funpred gamma_valid pd)
  (vt: val_typevar) (vv: val_vars pd vt)
  (p: predsym) (fs: list formula) (Hform: Forall (valid_formula sigma) fs):
  forall (P:
    forall srts : list sort,
    arg_list (domain (dom_aux pd))
      (sym_sigma_args p srts) ->
    bool
  ),
  (*If P holds of all of the constructors*)
  iter_and
  (map is_true
     (dep_map
        (formula_rep gamma_valid pd
          all_unif vt (interp_with_P pf p P)  vv) fs Hform)) ->
(*Then indpred_rep p fs x -> P x*)
  forall (srts : list sort)
  (a: arg_list (domain (dom_aux pd))
    (sym_sigma_args p srts)),
    indpred_rep_single pf vt vv p fs Hform srts a -> P srts a.
Proof.
  intros P Hand srts a. unfold indpred_rep_single.
  rewrite simpl_all_dec. intros.
  apply H. apply Hand.
Qed.

End Single.

End IndPropRep.


Require Import VST.msl.Extensionality.
Require Import VST.msl.sepalg.
Require Import CertiGraph.msl_ext.abs_addr.
Require Import CertiGraph.msl_ext.ramify_tactics.

Set Implicit Arguments.

Lemma join_identity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a b c, join a b c -> identity a -> identity b -> identity c.
Proof.
  intros.
  hnf; intros x y ?.
  try_join b x bx.
  apply H1 in H3.
  apply H0 in H4.
  subst; auto.
Qed.


Require Import ListAux.
Require Import TreeAux.
Require Import Tactics.
Lemma batchedq2consistent_ListRev0 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((list_member  il_0 u_1)) -> (list_member  il_1 u_1)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev1 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_head  il_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_1)) -> (list_order  il_1 u_0 u_1)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev2 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_head  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_1)) -> (not (list_head  il_1 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev3 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_head  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_1)) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev4 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev5 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_head  il_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev6 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_1 u_1))/\(list_order  il_0 u_0 u_1)/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (list_member  il_0 u_0)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev7 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_1 u_1))/\(list_order  il_0 u_0 u_1)/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (list_order  il_1 u_1 u_0)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev8 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_order  il_0 u_0 u_1))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_member  il_0 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev9 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev10 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_head  il_0 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev11 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev12 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_member  il_1 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev13 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_head  il_0 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev14 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_head  il_1 u_1))).
Proof.
  intro pushspec;
  inversion pushspec as [a b Hhd Hmem Hord Honce Hhd' Hhd'']; subst;
    try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce.
  intros. intro. eauto.
Qed.

Lemma batchedq2consistent_ListRev15 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev16 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(list_member  il_1 u_0)/\(not (list_member  il_0 u_1))) -> (list_member  il_0 u_0)).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev17 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_1 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_member  il_0 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev18 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_1 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_head  il_0 u_0))).
Proof. solve_reverse; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListRev19 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (reverse_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_1 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_head  il_1 u_0))).
Proof.
  intro pushspec;
    inversion pushspec as [a b Hhd Hmem Hord Honce Hhd' Hhd'']; subst;
      try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce.
  intros; destruct_pairs. intro. eauto.
Qed.


(******************************************************************************)
(**)
(******************************************************************************)
(* Let R : ringType                                                           *)
(******************************************************************************)
(* lmodZeroType R == an lmodType R structure for the unit type                *)
(* lmodRingType R == an lmodType R structure for R as a module over itself    *)

Require Import Coq.Program.Tactics.
From mathcomp Require Import ssreflect ssrfun eqtype choice.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Set Implicit Arguments.
Unset Strict Implicit.
Open Scope ring_scope.

Declare Scope lmod_scope.

Module lmodZero.
  Section Def.
  Definition zeroAdd := fun _ _ : unit => tt.
  Definition zeroNeg := fun _ : unit => tt.
  Definition zeroAbGroupA : associative zeroAdd. Proof. by []. Qed.
  Definition zeroAbGroupC : commutative zeroAdd. Proof. by []. Qed.
  Definition zeroAbGroup0z : left_id tt zeroAdd. Proof. by case. Qed.
  Definition zeroAbGroupIz : left_inverse tt zeroNeg zeroAdd. Proof. by case. Qed.

  Definition zeroAbGroup : zmodType :=
    ZmodType unit (GRing.Zmodule.Mixin zeroAbGroupA zeroAbGroupC zeroAbGroup0z zeroAbGroupIz).
  Canonical zeroAbGroup.

  Variable R : ringType.

  Definition zeroScale := (fun (_ : R) (_ : unit) => tt).
  Lemma zeroScale_id : left_id 1%R zeroScale. Proof. by case. Qed.
  Lemma zeroScale_rD : right_distributive zeroScale +%R. Proof. by rewrite /(GRing.add)=>/=. Qed.

  Lemma zeroScaleScale (a b : R) (v : unit) :
    zeroScale a (zeroScale b v) = zeroScale (a * b) v.
  Proof. by rewrite /(GRing.add)=>/=. Qed.

  Lemma zeroScaleMorph (v : unit) : {morph zeroScale^~ v : a b / a + b >-> a + b}.
  Proof. by rewrite /(GRing.add)=>/=. Qed.

  Definition type : lmodType R :=
    LmodType R unit (LmodMixin zeroScaleScale zeroScale_id zeroScale_rD zeroScaleMorph).
  End Def.
End lmodZero.

Notation lmodZeroType := lmodZero.type.

Module lmods.
  Section Def.
    Variable (R : ringType).
    Program Definition ringMod : lmodType R
     := LmodType R R (LmodMixin (@GRing.mulrA R) (@GRing.mul1r R) (@GRing.mulrDr R) _).
    Next Obligation. by move=>x y; rewrite GRing.mulrDl. Qed.

    Variable (A : lalgType R) (V : lmodType A).
    Definition AtoRscale := fun (r : R) (v : V) => (r *: (GRing.one A)) *: v.
    Lemma AtoRscale_id : left_id 1 AtoRscale.
    Proof. by rewrite/AtoRscale=>x; rewrite !GRing.scale1r. Qed.
    Lemma AtoRscale_rD : right_distributive AtoRscale +%R.
    Proof. by rewrite/AtoRscale=> x y z; rewrite GRing.scalerDr. Qed.

    Lemma AtoRScaleScale (a b : R) (v : V) :
    AtoRscale a (AtoRscale b v) = AtoRscale (a * b) v.
    Proof.     by rewrite/AtoRscale GRing.scalerA -GRing.scalerAl GRing.mul1r GRing.scalerA. Qed.

    Lemma AtoRScaleMorph (v : V) : {morph AtoRscale^~ v : a b / a + b >-> a + b}.
    Proof. by rewrite/AtoRscale=>r s; rewrite !GRing.scalerDl. Qed.

    Definition AtoRmod : lmodType R
    := LmodType R V (LmodMixin AtoRScaleScale AtoRscale_id AtoRscale_rD AtoRScaleMorph).

  End Def.
End lmods.
Notation ringModType := lmods.ringMod.
Close Scope ring_scope.


Require Forcing.
Require Import Eq.

Section Funext.

Variable Obj : Type.
Variable Hom : Obj -> Obj -> Type.

Opaque Hom.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Inductive eq {A : Type} (x : A) : A -> Type :=  eq_refl : eq x x
where "x = y :> A" := (@eq A x y) : type_scope.

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

Forcing Translate eq using Obj Hom.

Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
  := forall x:A, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.

Forcing Definition leibniz : forall A (x :A) (P : A -> Type),
    P x ->
    forall y (e:x = y), P y using Obj Hom.
Proof.
  intros p A x P P_refl y e.
  exact (match e p # in eqᶠ _ _ _ y'  return P p # y' p #
         with | eq_reflᶠ _ _ _ => P_refl p # end).
Defined.

Definition apD10 {A} {B:A->Type}
           {f g : forall x, B x} (h: f = g) :
  f == g.
Proof.
  refine (leibniz _ f (fun g => f == g) _ g h).
  intro. apply eq_refl.
Defined.

Forcing Translate pointwise_paths using Obj Hom.
Forcing Translate apD10 using Obj Hom.

Axiom funext_simpl_ : forall A (B : A -> Type) (f g : forall a, B a),
    f == g -> f = g.

Axiom uip_ : forall A (x:A) e, e = eq_refl x.

Definition uip := forall A (x:A) e, e = eq_refl x.

Forcing Translate uip using Obj Hom.

Definition eq__is_eq : forall p A (x y: forall p0 (f:p ≤ p0), A p0 f p0 #),
    x = y -> eqᶠ p _ x y.
Proof.
  intros. destruct H. apply eq_reflᶠ.
Defined.

Definition eq_is_eq_ : forall p A (x y: forall p0 (f:p ≤ p0), A p0 f p0 #),
   eqᶠ p _ x y -> x = y.
Proof.
  intros. destruct H. apply eq_refl.
Defined.

Definition eq_is_section : forall p A (x y: forall p0 (f:p ≤ p0), A p0 f p0 #)
    (e:x=y) (e':eqᶠ p _ x y),
  eq__is_eq _ _ _ _ e = e' -> e = eq_is_eq_ _ _ _ _ e'.
Proof.
  intros. destruct e. simpl in *.
  rewrite <- H. simpl. reflexivity.
Defined.

Definition eq_is_retraction : forall p A (x y: forall p0 (f:p ≤ p0), A p0 f p0 #)
    (e:x=y) (e':eqᶠ p _ x y),
  eq_is_eq_ _ _ _ _ e' = e -> e'  = eq__is_eq _ _ _ _ e.
Proof.
  intros. destruct e'. simpl in *.
  rewrite <- H. simpl. reflexivity.
Defined.

Forcing Definition uip_preservation : uip using Obj Hom.
Proof.
  intros p A x e.
  apply eq__is_eq.
  apply funext_simpl_. intro p1.
  apply funext_simpl_. intro α0.
  pose (uip_ _ _ (eq_is_eq_ _ _ _ _ (e p1 α0))).
  apply eq_is_retraction in e0. exact e0.
Defined.

End Funext.


Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.BinNat.
Require Import Coq.Arith.Arith.
Require Import bbv.WordScope.
Require Import Crypto.Util.FixedWordSizes.
Require Import Crypto.Util.WordUtil.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.

Definition wordT_beq_hetero {logsz1 logsz2} : wordT logsz1 -> wordT logsz2 -> bool
  := match logsz1 return wordT logsz1 -> wordT logsz2 -> bool with
     | 5 as logsz1' | 6 as logsz1' | 7 as logsz1'
     | _ as logsz1'
       => match logsz2 return wordT logsz1' -> wordT logsz2 -> bool with
          | 5 as logsz2' | 6 as logsz2' | 7 as logsz2'
          | _ as logsz2'
            => @Word.weqb_hetero (2^logsz1') (2^logsz2')
          end
     end.

(* transparent so the equality proof can compute away *)
Lemma pow2_inj_helper x y : 2^x = 2^y -> x = y.
Proof.
  destruct (NatUtil.nat_eq_dec x y) as [pf|pf]; [ intros; assumption | ].
  intro H; exfalso.
  let pf := pf in
  abstract (apply pf; eapply NPeano.Nat.pow_inj_r; [ | eassumption ]; omega).
Defined.
Lemma pow2_inj_helper_refl x p : pow2_inj_helper x x p = eq_refl.
Proof.
  induction x; simpl; [ reflexivity | ].
  etransitivity; [ | exact (f_equal (fun p => f_equal S p) (IHx eq_refl)) ]; clear IHx.
  unfold pow2_inj_helper in *; simpl.
  pose proof (NatUtil.nat_eq_dec_S x x).
  do 2 edestruct NatUtil.nat_eq_dec; try assumption; try (exfalso; assumption).
  match goal with
  | [ H : ?x <> ?x |- _ ] => exfalso; clear -H; exact (H eq_refl)
  end.
Defined.
Lemma pow2_inj_helper_eq_rect x y P v v'
  : (exists pf : 2^x = 2^y, eq_rect _ P v _ pf = v')
    -> (exists pf : x = y, eq_rect _ (fun e => P (2^e)) v _ pf = v').
Proof.
  intros [pf H]; exists (pow2_inj_helper x y pf); subst v'.
  destruct (NatUtil.nat_eq_dec x y) as [H|H];
    [ | exfalso; clear -pf H;
        let pf := pf in
        abstract (apply pow2_inj_helper in pf; omega) ].
  subst; rewrite pow2_inj_helper_refl; simpl.
  pose proof (NatUtil.UIP_nat_transparent _ _ pf eq_refl); subst pf.
  reflexivity.
Defined.

Definition wordT_beq_lb logsz1
  : forall x y : wordT logsz1, x = y -> wordT_beq_hetero x y = true
  := match logsz1 return forall x y : wordT logsz1, x = y -> wordT_beq_hetero x y = true with
     | 5 as logsz1' | 6 as logsz1' | 7 as logsz1'
     | _ as logsz1'
       => fun x y pf => proj2 (@Word.weqb_hetero_true_iff (2^logsz1') x (2^logsz1') y) (ex_intro _ eq_refl pf)
     end.
Definition wordT_beq_hetero_lb {logsz1 logsz2}
  : forall x y, (exists pf : logsz1 = logsz2, eq_rect _ wordT x _ pf = y) -> wordT_beq_hetero x y = true.
Proof.
  intros x y [pf H]; subst logsz2; revert x y H; simpl.
  apply wordT_beq_lb.
Defined.

Definition wordT_beq_bl logsz
  : forall x y : wordT logsz, wordT_beq_hetero x y = true -> x = y
  := match logsz return forall x y : wordT logsz, wordT_beq_hetero x y = true -> x = y with
     | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7
     | _
       => fun x y pf => proj1 (Word.weqb_hetero_homo_true_iff _ x y) pf
     end.

Lemma wordT_beq_hetero_type_lb_false logsz1 logsz2 x y : logsz1 <> logsz2 -> @wordT_beq_hetero logsz1 logsz2 x y = false.
Proof.
  destruct (wordT_beq_hetero x y) eqn:H; [ | reflexivity ].
  revert H.
  repeat (try destruct logsz1 as [|logsz1];
          try destruct logsz2 as [|logsz2];
          try (intros; omega);
          try (intro H'; apply Word.weqb_hetero_true_iff in H'; destruct H' as [pf H']; pose proof (pow2_inj_helper _ _ pf); try omega)).
Qed.

Definition wordT_beq_hetero_bl {logsz1 logsz2}
  : forall x y, wordT_beq_hetero x y = true -> (exists pf : logsz1 = logsz2, eq_rect _ wordT x _ pf = y).
Proof.
  refine match logsz1, logsz2 return forall x y, wordT_beq_hetero x y = true -> (exists pf : logsz1 = logsz2, eq_rect _ wordT x _ pf = y) with
         | 0, 0 | 1, 1 | 2, 2 | 3, 3 | 4, 4 | 5, 5 | 6, 6
         | 7, 7
           => fun x y pf => ex_intro _ eq_refl (@wordT_beq_bl _ x y pf)
         | S (S (S (S (S (S (S (S a))))))), S (S (S (S (S (S (S (S b)))))))
           => match NatUtil.nat_eq_dec a b with
              | left pf
                => match pf with
                   | eq_refl => fun x y pf => ex_intro _ eq_refl (@wordT_beq_bl _ x y pf)
                   end
              | right n => fun x y pf => match _ : False with end
              end
         | _, _
           => fun x y pf => match _ : False with end
         end;
    match goal with
    | [ pf : _ = _ |- _ ]
      => abstract (rewrite wordT_beq_hetero_type_lb_false in pf by omega; clear -pf; congruence)
    end.
Defined.

Lemma ZToWord_gen_wordToZ_gen : forall {sz} v, ZToWord_gen (@wordToZ_gen sz v) = v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros.
  rewrite N2Z.id, NToWord_wordToN; reflexivity.
Qed.

Lemma wordToZ_gen_ZToWord_gen : forall {sz} v, (0 <= v < 2^(Z.of_nat sz))%Z -> @wordToZ_gen sz (ZToWord_gen v) = v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros ?? [H0 H1].
  rewrite wordToN_NToWord_idempotent, Z2N.id; try omega.
  rewrite Npow2_N.
  apply Z2N.inj_lt in H1; [ | omega.. ].
  rewrite Z2N.inj_pow, <- nat_N_Z, N2Z.id in H1 by omega.
  assumption.
Qed.

Lemma wordToZ_gen_ZToWord_gen_mod : forall {sz} w, (0 <= w)%Z -> wordToZ_gen (@ZToWord_gen sz w) = (w mod (2^Z.of_nat sz))%Z.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros sz w H.
  rewrite wordToN_NToWord_mod.
  rewrite N2Z.inj_mod by (destruct sz; simpl; congruence).
  rewrite Z2N.id, N2Z.inj_pow, nat_N_Z by assumption.
  reflexivity.
Qed.

Lemma wordToZ_gen_ZToWord_gen_0 : forall {sz}, wordToZ_gen (@ZToWord_gen sz 0) = 0%Z.
Proof.
  intros; rewrite wordToZ_gen_ZToWord_gen_mod by reflexivity.
  rewrite Z.mod_0_l by auto with zarith.
  reflexivity.
Qed.

Lemma wordToZ_gen_ZToWord_gen_neg : forall {sz} w, (w <= 0)%Z -> wordToZ_gen (@ZToWord_gen sz w) = 0%Z.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros sz w H.
  destruct w.
  { apply wordToZ_gen_ZToWord_gen_0. }
  { compute in H; congruence. }
  { apply wordToZ_gen_ZToWord_gen_0. }
Qed.

Lemma wordToZ_gen_ZToWord_gen_mod_full : forall {sz} w, wordToZ_gen (@ZToWord_gen sz w) = (Z.max 0 w mod (2^Z.of_nat sz))%Z.
Proof.
  intros; apply Z.max_case_strong; intro.
  { apply wordToZ_gen_ZToWord_gen_neg; omega. }
  { apply wordToZ_gen_ZToWord_gen_mod; assumption. }
Qed.

Lemma ZToWord_gen_wordToZ_gen_ZToWord_gen : forall {sz1 sz2} v,
    (sz2 <= sz1)%nat -> @ZToWord_gen sz2 (wordToZ_gen (@ZToWord_gen sz1 v)) = ZToWord_gen v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros sz1 sz2 v H.
  rewrite N2Z.id, NToWord_wordToN_NToWord by omega.
  reflexivity.
Qed.

Lemma ZToWord_gen_wordToZ_gen_ZToWord_gen_small : forall {sz1 sz2} v,
    (wordToZ_gen (@ZToWord_gen sz2 v) < 2^(Z.of_nat sz1))%Z
    -> @ZToWord_gen sz2 (wordToZ_gen (@ZToWord_gen sz1 v)) = ZToWord_gen v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros sz1 sz2 v H.
  change 2%Z with (Z.of_nat 2) in H.
  rewrite <- !nat_N_Z, <- N2Z.inj_pow, <- N2Z.inj_lt in H.
  rewrite N2Z.id, NToWord_wordToN_NToWord_small by assumption.
  reflexivity.
Qed.

Lemma wordToZ_gen_ZToWord_gen_wordToZ_gen sz1 sz2 w
  : (sz1 <= sz2)%nat -> wordToZ_gen (@ZToWord_gen sz2 (@wordToZ_gen sz1 w)) = wordToZ_gen w.
Proof.
  unfold ZToWord_gen, wordToZ_gen; intro H.
  rewrite N2Z.id, wordToN_NToWord_wordToN by omega.
  reflexivity.
Qed.

Lemma eq_ZToWord_gen : forall {sz} v1 v2, (Z.max 0 v1 mod 2^Z.of_nat sz = Z.max 0 v2 mod 2^Z.of_nat sz)%Z
                                          <-> @ZToWord_gen sz v1 = @ZToWord_gen sz v2.
Proof.
  intros; split; intro H.
  { rewrite <- (ZToWord_gen_wordToZ_gen (ZToWord_gen v1)), <- (ZToWord_gen_wordToZ_gen (ZToWord_gen v2)).
    rewrite !wordToZ_gen_ZToWord_gen_mod_full.
    congruence. }
  { apply (f_equal wordToZ_gen) in H; revert H.
    rewrite !wordToZ_gen_ZToWord_gen_mod_full.
    trivial. }
Qed.

Lemma ZToWord_wordToZ : forall {sz} v, ZToWord (@wordToZ sz v) = v.
Proof.
  unfold wordT, word_case in *.
  intro sz; break_match; simpl; apply ZToWord_gen_wordToZ_gen.
Qed.

Lemma wordToZ_ZToWord : forall {sz} v, (0 <= v < 2^(Z.of_nat (2^sz)))%Z -> @wordToZ sz (ZToWord v) = v.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros; break_match; apply wordToZ_gen_ZToWord_gen;
    assumption.
Qed.

Lemma wordToZ_ZToWord_mod : forall {sz} v, (0 <= v)%Z -> wordToZ (@ZToWord sz v) = (v mod (2^Z.of_nat (2^sz)))%Z.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros; break_match; apply wordToZ_gen_ZToWord_gen_mod;
    assumption.
Qed.

Local Ltac handle_le :=
  repeat match goal with
         | [ |- (S ?a <= 2^?b)%nat ]
           => change (2^(Nat.log2 (S a)) <= 2^b)%nat
         | [ |- (2^_ <= 2^_)%nat ]
           => apply Nat.pow_le_mono_r
         | [ |- _ <> _ ] => intro; omega
         | _ => assumption
         | [ |- (_ <= S _)%nat ]
           => apply Nat.leb_le; vm_compute; reflexivity
         | _ => exfalso; omega
         end.

Lemma ZToWord_wordToZ_ZToWord : forall {sz1 sz2} v,
    (sz2 <= sz1)%nat -> @ZToWord sz2 (wordToZ (@ZToWord sz1 v)) = ZToWord v.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz1 sz2; break_match; intros; apply ZToWord_gen_wordToZ_gen_ZToWord_gen;
    handle_le.
Qed.

Lemma ZToWord_wordToZ_ZToWord_small : forall {sz1 sz2} v,
    (wordToZ (@ZToWord sz2 v) < 2^Z.of_nat (2^sz1))%Z -> @ZToWord sz2 (wordToZ (@ZToWord sz1 v)) = ZToWord v.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz1 sz2; break_match; intros; apply ZToWord_gen_wordToZ_gen_ZToWord_gen_small;
    handle_le; try omega.
Qed.

Lemma wordToZ_ZToWord_wordToZ : forall sz1 sz2 w, (sz1 <= sz2)%nat -> wordToZ (@ZToWord sz2 (@wordToZ sz1 w)) = wordToZ w.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz1 sz2; break_match; intros; apply wordToZ_gen_ZToWord_gen_wordToZ_gen;
    handle_le.
Qed.

Lemma wordToZ_ZToWord_0 : forall {sz}, wordToZ (@ZToWord sz 0) = 0%Z.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz; break_match; intros; apply wordToZ_gen_ZToWord_gen_0.
Qed.

Lemma wordToZ_ZToWord_neg : forall {sz} w, (w <= 0)%Z -> wordToZ (@ZToWord sz w) = 0%Z.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz w; break_match; apply wordToZ_gen_ZToWord_gen_neg.
Qed.

Lemma wordToZ_ZToWord_mod_full : forall {sz} w, wordToZ (@ZToWord sz w) = ((Z.max 0 w) mod (2^Z.of_nat (2^sz)))%Z.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz w; break_match; apply wordToZ_gen_ZToWord_gen_mod_full.
Qed.

Lemma eq_ZToWord : forall {sz} v1 v2, (Z.max 0 v1 mod 2^Z.of_nat (2^sz) = Z.max 0 v2 mod 2^Z.of_nat (2^sz))%Z
                                      <-> @ZToWord sz v1 = @ZToWord sz v2.
Proof.
  unfold ZToWord, word_case_dep.
  intros sz v1 v2; break_innermost_match; apply eq_ZToWord_gen.
Qed.

Local Ltac wordToZ_word_case_dep_t :=
  let H := fresh in
  intro H;
  intros; unfold wordToZ, word_case_dep, wordT, word_case, word32, word64, word128, word32ToZ, word64ToZ, word128ToZ in *;
  break_innermost_match;
  change 128%nat with (2^7)%nat in *;
  change 64%nat with (2^6)%nat in *;
  change 32%nat with (2^5)%nat in *;
  apply H.

Lemma wordToZ_word_case_dep_unop (wop : forall sz, word sz -> word sz)
      (P : nat -> Z -> Z -> Type)
  : (forall logsz (x : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen (wop (2^logsz) x)))
    -> forall logsz (x : wordT logsz), P logsz (wordToZ x) (wordToZ (word_case_dep (T:=fun _ W => W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) x)).
Proof. wordToZ_word_case_dep_t. Qed.

Lemma wordToZ_word_case_dep_11op {T} (wop : forall sz, T -> word sz -> word sz)
      (P : nat -> Z -> Z -> Type)
      {v}
  : (forall logsz (x : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen (wop (2^logsz) v x)))
    -> forall logsz (x : wordT logsz), P logsz (wordToZ x) (wordToZ (word_case_dep (T:=fun _ W => T -> W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) v x)).
Proof. wordToZ_word_case_dep_t. Qed.

Lemma wordToZ_word_case_dep_binop (wop : forall sz, word sz -> word sz -> word sz)
      (P : nat -> Z -> Z -> Z -> Type)
  : (forall logsz (x y : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen y) (wordToZ_gen (wop (2^logsz) x y)))
    -> forall logsz (x y : wordT logsz), P logsz (wordToZ x) (wordToZ y) (wordToZ (word_case_dep (T:=fun _ W => W -> W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) x y)).
Proof. wordToZ_word_case_dep_t. Qed.

Lemma wordToZ_word_case_dep_quadop (wop : forall sz, word sz -> word sz -> word sz -> word sz -> word sz)
      (P : nat -> Z -> Z -> Z -> Z -> Z -> Type)
  : (forall logsz (x y z w : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen y) (wordToZ_gen z) (wordToZ_gen w) (wordToZ_gen (wop (2^logsz) x y z w)))
    -> forall logsz (x y z w : wordT logsz), P logsz (wordToZ x) (wordToZ y) (wordToZ z) (wordToZ w) (wordToZ (word_case_dep (T:=fun _ W => W -> W -> W -> W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) x y z w)).
Proof. wordToZ_word_case_dep_t. Qed.

(** This converts goals involving (currently only binary) [wordT]
    operations to the corresponding goals involving [word]
    operations. *)
Ltac syntactic_fixed_size_op_to_word :=
  lazymatch goal with
  | [ |- context[wordToZ (word_case_dep (T:=?T) ?logsz (?wop 32) (?wop 64) (?wop 128) ?f ?x)] ]
    => move x at top;
       revert dependent logsz; intros logsz x;
       pattern (wordToZ x), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x));
       let P := lazymatch goal with |- ?P _ _ => P end in
       let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
       revert logsz x;
       refine (@wordToZ_word_case_dep_unop wop P _);
       intros logsz x; intros
  | [ |- context[wordToZ (word_case_dep (T:=?T) ?logsz (?wop 32) (?wop 64) (?wop 128) ?f ?x ?y)] ]
    => lazymatch type of x with
       | context[logsz]
         => move y at top; move x at top;
            revert dependent logsz; intros logsz x y;
            pattern (wordToZ x), (wordToZ y), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x y));
            let P := lazymatch goal with |- ?P _ _ _ => P end in
            let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
            revert logsz x y;
            refine (@wordToZ_word_case_dep_binop wop P _);
            intros logsz x y; intros
       | _
         => move y at top;
            revert dependent logsz; intros logsz y;
            pattern (wordToZ y), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x y));
            let P := lazymatch goal with |- ?P _ _ => P end in
            let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
            revert logsz y;
            refine (@wordToZ_word_case_dep_11op _ wop P x _);
            intros logsz y; intros
       end
  | [ |- context[wordToZ (word_case_dep (T:=?T) ?logsz (?wop 32) (?wop 64) (?wop 128) ?f ?x ?y ?z ?w)] ]
    => move w at top; move z at top; move y at top; move x at top;
       revert dependent logsz; intros logsz x y z w;
       pattern (wordToZ x), (wordToZ y), (wordToZ z), (wordToZ w), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x y z w));
       let P := lazymatch goal with |- ?P _ _ _ _ _ => P end in
       let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
       revert logsz x y z w;
       refine (@wordToZ_word_case_dep_quadop wop P _);
       intros logsz x y z w; intros
  end.
Ltac fixed_size_op_to_word :=
  repeat autounfold with fixed_size_constants in *;
  syntactic_fixed_size_op_to_word.

Lemma wordToZ_gen_range {sz} w : (0 <= @wordToZ_gen sz w < 2^Z.of_nat sz)%Z.
Proof. apply WordNZ_range; reflexivity. Qed.

Lemma wordToZ_range {logsz} w : (0 <= @wordToZ logsz w < 2^Z.of_nat (2^logsz))%Z.
Proof.
  generalize (@wordToZ_gen_range (2^logsz)); wordToZ_word_case_dep_t.
Qed.

Section log_Updates.
  Local Notation bound n lower value upper := (
       (0 <= lower)%Z
    /\ (lower <= @wordToZ n value)%Z
    /\ (@wordToZ n value <= upper)%Z
    /\ (Z.log2 upper < Z.of_nat (2^n))%Z).

  Definition valid_log_update n lowerF valueF upperF : Prop :=
    forall lower0 value0 upper0
          lower1 value1 upper1,

       bound n lower0 value0 upper0
    -> bound n lower1 value1 upper1
    -> (0 <= lowerF lower0 upper0 lower1 upper1)%Z
    -> (Z.log2 (upperF lower0 upper0 lower1 upper1) < Z.of_nat (2^n))%Z
    -> bound n (lowerF lower0 upper0 lower1 upper1)
                (valueF value0 value1)
                (upperF lower0 upper0 lower1 upper1).

  Lemma word_case_dep_valid_log_update f g wop
    : (forall n,
          WordUtil.valid_update
            n
            f
            (wop n)
            g)
      -> forall n,
          valid_log_update
            n
            f
            (word_case_dep
               (T:=fun _ W => W -> W -> W)
               n (wop 32) (wop 64) (wop 128)
               (fun k : nat => wop (2 ^ k)))
            g.
  Proof.
    intros H n; specialize (H (2^n)%nat).
    unfold valid_log_update; intros; fixed_size_op_to_word; unfold wordToZ_gen; auto.
  Qed.

  Lemma wadd_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => l0 + l1)%Z
        (@wadd n)
        (fun l0 u0 l1 u1 => u0 + u1)%Z.
  Proof. apply word_case_dep_valid_log_update, add_valid_update. Qed.

  Lemma wsub_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => l0 - u1)%Z
        (@wsub n)
        (fun l0 u0 l1 u1 => u0 - l1)%Z.
  Proof. apply word_case_dep_valid_log_update, sub_valid_update. Qed.

  Lemma wmul_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => l0 * l1)%Z
        (@wmul n)
        (fun l0 u0 l1 u1 => u0 * u1)%Z.
  Proof. apply word_case_dep_valid_log_update, mul_valid_update. Qed.

  Lemma wland_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => 0)%Z
        (@wland n)
        (fun l0 u0 l1 u1 => Z.min u0 u1)%Z.
  Proof. apply word_case_dep_valid_log_update, land_valid_update. Qed.

  Lemma wlor_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => Z.max l0 l1)%Z
        (@wlor n)
        (fun l0 u0 l1 u1 => 2^(Z.max (Z.log2_up (u0+1)) (Z.log2_up (u1+1))) - 1)%Z.
  Proof. apply word_case_dep_valid_log_update, lor_valid_update. Qed.

  Lemma wshr_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => Z.shiftr l0 u1)%Z
        (@wshr n)
        (fun l0 u0 l1 u1 => Z.shiftr u0 l1)%Z.
  Proof. apply word_case_dep_valid_log_update, shr_valid_update. Qed.

  Lemma wshl_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => Z.shiftl l0 l1)%Z
        (@wshl n)
        (fun l0 u0 l1 u1 => Z.shiftl u0 u1)%Z.
  Proof. apply word_case_dep_valid_log_update, shl_valid_update. Qed.
End log_Updates.

Lemma lt_log_helper (v : Z) (n : nat)
  : (v < 2^2^Z.of_nat n)%Z <-> (Z.log2 v < Z.of_nat (2^n))%Z.
Proof.
  rewrite Z.log2_lt_pow2_alt, Z.pow_Zpow by auto with zarith.
  reflexivity.
Qed.

Section Updates.
  Local Notation bound n lower value upper := (
       (0 <= lower)%Z
    /\ (lower <= @wordToZ n value)%Z
    /\ (@wordToZ n value <= upper)%Z
    /\ (upper < 2^2^Z.of_nat n)%Z).

  Definition valid_update n lowerF valueF upperF : Prop :=
    forall lower0 value0 upper0
           lower1 value1 upper1,
      bound n lower0 value0 upper0
      -> bound n lower1 value1 upper1
      -> (0 <= lowerF lower0 upper0 lower1 upper1)%Z
      -> (upperF lower0 upper0 lower1 upper1 < 2^2^Z.of_nat n)%Z
      -> bound n (lowerF lower0 upper0 lower1 upper1)
               (valueF value0 value1)
               (upperF lower0 upper0 lower1 upper1).

  Local Ltac t lem :=
    let H := fresh in
    pose proof lem as H;
    repeat (let x := fresh in intro x; specialize (H x));
    rewrite !lt_log_helper; assumption.

  Lemma word_case_dep_valid_update f g wop
    : (forall n,
          WordUtil.valid_update
            n
            f
            (wop n)
            g)
      -> forall n,
          valid_update
            n
            f
            (word_case_dep
               (T:=fun _ W => W -> W -> W)
               n (wop 32) (wop 64) (wop 128)
               (fun k : nat => wop (2 ^ k)))
            g.
  Proof. t (@word_case_dep_valid_log_update f g wop). Qed.

  Lemma wadd_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 + l1)%Z
        (@wadd n)
        (fun l0 u0 l1 u1 => u0 + u1)%Z.
  Proof. t (@wadd_valid_log_update). Qed.

  Lemma wsub_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 - u1)%Z
        (@wsub n)
        (fun l0 u0 l1 u1 => u0 - l1)%Z.
  Proof. t (@wsub_valid_log_update). Qed.

  Lemma wmul_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 * l1)%Z
        (@wmul n)
        (fun l0 u0 l1 u1 => u0 * u1)%Z.
  Proof. t (@wmul_valid_log_update). Qed.

  Lemma wland_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => 0)%Z
        (@wland n)
        (fun l0 u0 l1 u1 => Z.min u0 u1)%Z.
  Proof. t (@wland_valid_log_update). Qed.

  Lemma wlor_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.max l0 l1)%Z
        (@wlor n)
        (fun l0 u0 l1 u1 => 2^(Z.max (Z.log2_up (u0+1)) (Z.log2_up (u1+1))) - 1)%Z.
  Proof. t (@wlor_valid_log_update). Qed.

  Lemma wshr_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.shiftr l0 u1)%Z
        (@wshr n)
        (fun l0 u0 l1 u1 => Z.shiftr u0 l1)%Z.
  Proof. t (@wshr_valid_log_update). Qed.

  Lemma wshl_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.shiftl l0 l1)%Z
        (@wshl n)
        (fun l0 u0 l1 u1 => Z.shiftl u0 u1)%Z.
  Proof. t (@wshl_valid_log_update). Qed.
End Updates.

Section pull_ZToWord.
  Local Ltac t0 :=
    intros;
    etransitivity; [ symmetry; apply ZToWord_wordToZ | ]; fixed_size_op_to_word; unfold wordToZ_gen, wordBin;
    apply f_equal.
  Local Ltac t1 lem :=
    let solver := solve [ apply Npow2_Zlog2; autorewrite with push_Zof_N; assumption
                        | apply N2Z.inj_ge; unfold wordToZ_gen in *; omega
                        | apply N2Z.inj_lt; rewrite Npow2_N; autorewrite with push_Zof_N push_Zof_nat; assumption ] in
    first [ rewrite <- lem by solver | rewrite -> lem by solver ].
  Local Ltac t2 :=
    autorewrite with push_Zof_N; unfold wordToZ_gen in *;
    try first [ reflexivity
              | apply Z.max_case_strong; omega ].

  Local Ltac t lem :=
    t0; t1 lem; solve [ t2 ].

  Local Notation pull_ZToWordT_2op wop zop
    := (forall {logsz} (x y : wordT logsz),
           (zop (wordToZ x) (wordToZ y) < 2^2^Z.of_nat logsz)%Z
           -> wop logsz x y = ZToWord (zop (wordToZ x) (wordToZ y)))
         (only parsing).
  Local Notation pull_ZToWordT_2op' wop zop
    := (forall {logsz} (x y : wordT logsz),
           (0 <= zop (wordToZ x) (wordToZ y))%Z
           -> wop logsz x y = ZToWord (zop (wordToZ x) (wordToZ y)))
         (only parsing).

  Lemma wadd_def_ZToWord : pull_ZToWordT_2op (@wadd) (@Z.add).
  Proof. t (@wordize_plus). Qed.
  Lemma wsub_def_ZToWord : pull_ZToWordT_2op' (@wsub) (@Z.sub).
  Proof. t (@wordize_minus). Qed.
  Lemma wmul_def_ZToWord : pull_ZToWordT_2op (@wmul) (@Z.mul).
  Proof. t (@wordize_mult). Qed.
  Lemma wland_def_ZToWord : pull_ZToWordT_2op (@wland) (@Z.land).
  Proof. t (@wordize_and). Qed.
  Lemma wlor_def_ZToWord : pull_ZToWordT_2op (@wlor) (@Z.lor).
  Proof. t (@wordize_or). Qed.
  Lemma wshl_def_ZToWord : pull_ZToWordT_2op (@wshl) (@Z.shiftl).
  Proof. t (@wordToN_NToWord_idempotent). Qed.
  Lemma wshr_def_ZToWord : pull_ZToWordT_2op (@wshr) (@Z.shiftr).
  Proof. t (@wordToN_NToWord_idempotent). Qed.
End pull_ZToWord.
Section pull_ZToWord_log.
  Local Ltac t lem :=
    let H := fresh in
    pose proof lem as H;
    repeat (let x := fresh in intro x; specialize (H x));
    rewrite <- !lt_log_helper; assumption.

  Local Notation pull_ZToWordT_log_2op wop zop
    := (forall {logsz} (x y : wordT logsz),
           (Z.log2 (zop (wordToZ x) (wordToZ y)) < Z.of_nat (2^logsz))%Z
           -> wop logsz x y = ZToWord (zop (wordToZ x) (wordToZ y)))
         (only parsing).
  Lemma wadd_def_ZToWord_log : pull_ZToWordT_log_2op (@wadd) (@Z.add).
  Proof. t (@wadd_def_ZToWord). Qed.
  Lemma wmul_def_ZToWord_log : pull_ZToWordT_log_2op (@wmul) (@Z.mul).
  Proof. t (@wmul_def_ZToWord). Qed.
  Lemma wland_def_ZToWord_log : pull_ZToWordT_log_2op (@wland) (@Z.land).
  Proof. t (@wland_def_ZToWord). Qed.
  Lemma wlor_def_ZToWord_log : pull_ZToWordT_log_2op (@wlor) (@Z.lor).
  Proof. t (@wlor_def_ZToWord). Qed.
  Lemma wshl_def_ZToWord_log : pull_ZToWordT_log_2op (@wshl) (@Z.shiftl).
  Proof. t (@wshl_def_ZToWord). Qed.
  Lemma wshr_def_ZToWord_log : pull_ZToWordT_log_2op (@wshr) (@Z.shiftr).
  Proof. t (@wshr_def_ZToWord). Qed.
End pull_ZToWord_log.
Hint Rewrite wadd_def_ZToWord wsub_def_ZToWord wmul_def_ZToWord wland_def_ZToWord wlor_def_ZToWord wshl_def_ZToWord wshr_def_ZToWord : pull_ZToWord.
Hint Rewrite <- wadd_def_ZToWord wsub_def_ZToWord wmul_def_ZToWord wland_def_ZToWord wlor_def_ZToWord wshl_def_ZToWord wshr_def_ZToWord : push_ZToWord.
Hint Rewrite wadd_def_ZToWord_log wsub_def_ZToWord wmul_def_ZToWord_log wland_def_ZToWord_log wlor_def_ZToWord_log wshl_def_ZToWord_log wshr_def_ZToWord_log : pull_ZToWord_log.
Hint Rewrite <- wadd_def_ZToWord_log wsub_def_ZToWord wmul_def_ZToWord_log wland_def_ZToWord_log wlor_def_ZToWord_log wshl_def_ZToWord_log wshr_def_ZToWord_log : push_ZToWord_log.