From iris.base_logic.lib Require Export invariants.
From iris.bi.lib Require Import fractional.
From iris.algebra Require Export frac.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

Class cinvG Σ := cinv_inG :> inG Σ fracR.
Definition cinvΣ : gFunctors := #[GFunctor fracR].

Instance subG_cinvΣ {Σ} : subG cinvΣ Σ → cinvG Σ.
Proof. solve_inG. Qed.

Section defs.
  Context `{invG Σ, cinvG Σ}.

  Definition cinv_own (γ : gname) (p : frac) : iProp Σ := own γ p.

  Definition cinv (N : namespace) (γ : gname) (P : iProp Σ) : iProp Σ :=
    (∃ P', □ ▷ (P ↔ P') ∗ inv N (P' ∨ cinv_own γ 1%Qp))%I.
End defs.

Instance: Params (@cinv) 5.

Section proofs.
  Context `{invG Σ, cinvG Σ}.

  Global Instance cinv_own_timeless γ p : Timeless (cinv_own γ p).
  Proof. rewrite /cinv_own; apply _. Qed.

  Global Instance cinv_contractive N γ : Contractive (cinv N γ).
  Proof. solve_contractive. Qed.
  Global Instance cinv_ne N γ : NonExpansive (cinv N γ).
  Proof. exact: contractive_ne. Qed.
  Global Instance cinv_proper N γ : Proper ((≡) ==> (≡)) (cinv N γ).
  Proof. exact: ne_proper. Qed.

  Global Instance cinv_persistent N γ P : Persistent (cinv N γ P).
  Proof. rewrite /cinv; apply _. Qed.

  Global Instance cinv_own_fractional γ : Fractional (cinv_own γ).
  Proof. intros ??. by rewrite /cinv_own -own_op. Qed.
  Global Instance cinv_own_as_fractional γ q :
    AsFractional (cinv_own γ q) (cinv_own γ) q.
  Proof. split. done. apply _. Qed.

  Lemma cinv_own_valid γ q1 q2 : cinv_own γ q1 -∗ cinv_own γ q2 -∗ ✓ (q1 + q2)%Qp.
  Proof. apply (own_valid_2 γ q1 q2). Qed.

  Lemma cinv_own_1_l γ q : cinv_own γ 1 -∗ cinv_own γ q -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct (cinv_own_valid with "H1 H2") as %[]%(exclusive_l 1%Qp).
  Qed.

  Lemma cinv_iff N γ P P' :
    ▷ □ (P ↔ P') -∗ cinv N γ P -∗ cinv N γ P'.
  Proof.
    iIntros "#HP' Hinv". iDestruct "Hinv" as (P'') "[#HP'' Hinv]".
    iExists _. iFrame "Hinv". iAlways. iNext. iSplit.
    - iIntros "?". iApply "HP''". iApply "HP'". done.
    - iIntros "?". iApply "HP'". iApply "HP''". done.
  Qed.

  Lemma cinv_alloc_strong (G : gset gname) E N :
    (|={E}=> ∃ γ, ⌜ γ ∉ G ⌝ ∧ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P)%I.
  Proof.
    iMod (own_alloc_strong 1%Qp G) as (γ) "[Hfresh Hγ]"; first done.
    iExists γ; iIntros "!> {$Hγ $Hfresh}" (P) "HP".
    iMod (inv_alloc N _ (P ∨ own γ 1%Qp)%I with "[HP]"); first by eauto.
    iIntros "!>". iExists P. iSplit; last done. iIntros "!# !>"; iSplit; auto.
  Qed.

  Lemma cinv_open_strong E N γ p P :
    ↑N ⊆ E →
    cinv N γ P -∗ cinv_own γ p ={E,E∖↑N}=∗
    ▷ P ∗ cinv_own γ p ∗ (▷ P ∨ cinv_own γ 1 ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "#Hinv Hγ". iDestruct "Hinv" as (P') "[#HP' Hinv]".
    iInv N as "[HP | >Hγ']" "Hclose".
    - iIntros "!> {$Hγ}". iSplitL "HP".
      + iNext. iApply "HP'". done.
      + iIntros "[HP|Hγ]".
        * iApply "Hclose". iLeft. iNext. by iApply "HP'".
        * iApply "Hclose". iRight. by iNext.
    - iDestruct (cinv_own_1_l with "Hγ' Hγ") as %[].
  Qed.

  Lemma cinv_alloc E N P : ▷ P ={E}=∗ ∃ γ, cinv N γ P ∗ cinv_own γ 1.
  Proof.
    iIntros "HP". iMod (cinv_alloc_strong ∅ E N) as (γ _) "[Hγ Halloc]".
    iExists γ. iFrame "Hγ". by iApply "Halloc".
  Qed.

  Lemma cinv_cancel E N γ P : ↑N ⊆ E → cinv N γ P -∗ cinv_own γ 1 ={E}=∗ ▷ P.
  Proof.
    iIntros (?) "#Hinv Hγ".
    iMod (cinv_open_strong with "Hinv Hγ") as "($ & Hγ & H)"; first done.
    iApply "H". by iRight.
  Qed.

  Lemma cinv_open E N γ p P :
    ↑N ⊆ E →
    cinv N γ P -∗ cinv_own γ p ={E,E∖↑N}=∗ ▷ P ∗ cinv_own γ p ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "#Hinv Hγ".
    iMod (cinv_open_strong with "Hinv Hγ") as "($ & $ & H)"; first done.
    iIntros "!> HP". iApply "H"; auto.
  Qed.

  Global Instance into_inv_cinv N γ P : IntoInv (cinv N γ P) N.

  Global Instance into_acc_cinv E N γ P p :
    IntoAcc (X:=unit) (cinv N γ P)
            (↑N ⊆ E) (cinv_own γ p) (fupd E (E∖↑N)) (fupd (E∖↑N) E)
            (λ _, ▷ P ∗ cinv_own γ p)%I (λ _, ▷ P)%I (λ _, None)%I.
  Proof.
    rewrite /IntoAcc /accessor. iIntros (?) "#Hinv Hown".
    rewrite exist_unit -assoc.
    iApply (cinv_open with "Hinv"); done.
  Qed.
End proofs.

Typeclasses Opaque cinv_own cinv.


Require Import Ynot Basis.
Require Import UdpServer TcpServer SslServer.
Require Import IO Net FS.
Require Import Parsers.
Require Import Stream Parsec Charset.
Require Import List Ascii String.

Require Import RSep.
Import STRING_INSTREAM.
Import INSTREAM.
Import Expressions.

Open Local Scope hprop_scope.
Open Local Scope stsepi_scope.

Set Implicit Arguments.

Module Type EVALPARAMS.

  Variable t: Set.
  Variable grammar : Term AsciiCharset t.
  Variable parser  : parser_t grammar.
  Variable e : list ascii.      (* error list ascii *)
  Variable f : t -> list ascii. (* value serializer *)

End EVALPARAMS.

Module PrefixServer : EVALPARAMS.
 Import Expressions.
 Definition t := nat.
 Definition grammar : Term AsciiCharset nat := prefix.
 Definition parser := prefix_p.
 Require Import Ascii.
 Open Scope char_scope.

 Definition e : list ascii := str2la "error"%string.
 Definition f x := str2la (ntos x).

End PrefixServer.

Module UdpEvalServerParams (A : EVALPARAMS) : UdpServer.EXECPARAMS.
  Export A.

  Definition resp (CH : Charset) (r :reply_t CH t) :=
    match r with
      | Okay _ a _ => f a
      | Error _ => e
    end.

  Inductive ccorrect' (req : list ascii) : Trace -> Prop :=
  | NilCorrect : ccorrect' req nil.
  Definition ccorrect := ccorrect'.

  Inductive reply' (req : list ascii) : list ascii -> Prop :=
  | ReplyIdentity : forall v, parses grammar req v -> reply' req (resp v).
  Definition reply := reply'.

  Definition io : forall (req : list ascii) (tr : [Trace]),
    STsep (tr ~~ traced tr)
          (fun r:(list ascii * [Trace]) => tr ~~ tr' :~~ (snd r) in traced (tr' ++ tr) * [reply req (fst r)] * [ccorrect req tr']).
    refine (fun req tr =>
      is  <- instream_of_list_ascii req <@> _ ;
      ans <- parser is (inhabits 0) <@> (tr ~~ elts :~~ (stream_elts is) in traced tr * [elts = req]);

      close is <@> _ ;;
      {{ Return (match ans with
                   | ERROR _ _ =>  e
                   | OKAY _ _ a => f a
                 end, [nil]%inhabited) }}).
    rsep fail auto.
    rsep fail auto.
    lazy zeta. rsep fail auto.
    rsep fail auto.
    solve [ unfold ans_str_correct, okaystr, errorstr;
            instantiate (1 := tr ~~
              hprop_unpack (stream_elts is)
              (fun elts =>
                traced tr * [elts = req] *
                match ans with
                  | OKAY c m v =>
                    @okay AsciiCharset _ [0] is grammar c m v
                  | ERROR c _ => @error AsciiCharset _ [0] is grammar c
                end));
            destruct ans; sep fail auto ].
    solve [ sep fail auto ].
    solve [ sep fail auto ].
    unfold char, okay, error in *. rsep fail auto. subst; norm_prod. destruct ans. rsep ltac:(norm_list) auto. cut_pure.
    pose (ReplyIdentity H1). simpl in *. unfold char in *. rewrite H in H0. rewrite <- (pack_injective H0); auto.

    rsep ltac:(norm_list) auto. cut_pure; try constructor; auto. unfold reply. pose (ReplyIdentity H1). simpl in *. unfold char in *. rewrite H in H0. rewrite <- (pack_injective H0); auto.
  Qed.

End UdpEvalServerParams.

Module TcpEvalServerParams (A : EVALPARAMS).
  Export A.

  Ltac solver := auto.

  Definition resp (CH : Charset) (r :reply_t CH t) :=
    match r with
      | Okay _ a _ => f a
      | Error _ => e
    end.

  Inductive ccorrect' (local remote : SockAddr) (fd : File (BoundSocketModel local remote) (R :: W :: nil)) : Trace -> Prop :=
  | DoneCorrect : forall past, ecorrect fd past -> ccorrect' fd (Flush fd :: ReadLine fd nil ++ past)
  with ecorrect (local remote : SockAddr) (fd : File (BoundSocketModel local remote) (R :: W :: nil)) : Trace -> Prop :=
  | NilCorrect : ecorrect fd nil
  | ConsCorrect : forall s v past rep, s <> nil -> rep = resp v -> ecorrect fd past -> parses grammar s v ->
    ecorrect fd (Flush fd :: WroteString fd rep ++ ReadLine fd s ++ past).
  Definition ccorrect := ccorrect'.

  Definition traceCombine (t1 t2 : [Trace]) := inhabit_unpack2 t1 t2 (fun t1 t2 => t1 ++ t2).
  Definition traceAfter (t1 t2 : [Trace]) (f : Trace -> Trace) := inhabit_unpack2 t1 t2 (fun t1 t2 => f (t1 ++ t2)).

  Definition empty_eq : forall T (a : list T), {a = nil} + {a <> nil}.
    intros; destruct a; firstorder.
  Qed.

  Ltac rcombine := idtac;
    match goal with
      | [ H : traceCombine ?X ?Y = [_]%inhabited |- _ ] =>
        rwpack X H; rwpack Y H; simpl in H; rewrite <- (pack_injective H) in *; clear H
      | [ H : traceAfter ?X ?Y _ = [_]%inhabited |- _ ] =>
        rwpack X H; rwpack Y H; simpl in H; rewrite <- (pack_injective H) in *; clear H
      | [ H : (inhabit_unpack ?X _) = [_]%inhabited |- _ ] =>
        rwpack X H; simpl in H; rewrite <- (pack_injective H)
    end.

  Definition io : forall (local remote : SockAddr) (fd : File (BoundSocketModel local remote) (R :: W :: nil)) (tr : [Trace]),
    STsep (tr ~~ traced tr * handle fd)
          (fun tr':[Trace] => tr ~~ tr' ~~ traced (tr' ++ tr) * [ccorrect fd tr']).
    intros. refine (
      lt <- Fix (fun tr' => tr ~~ tr' ~~ traced (tr' ++ tr) * [ecorrect fd tr'] * handle fd)
                (fun _ tr' => tr ~~ tr' ~~ traced (tr' ++ tr) * [ccorrect fd tr'])
                (fun self tr' =>
                  str <- readline fd rw_readable (traceCombine tr' tr) <@> (tr' ~~ [ecorrect fd tr']);
                  if empty_eq str then
                    flush fd (traceAfter tr' tr (fun t => ReadLine fd str ++ t)) rw_writeable <@>
                      (tr' ~~ [ecorrect fd tr']) ;;
                    FS.close fd <@> (tr ~~ tr' ~~ [ecorrect fd tr'] * traced (Flush fd :: ReadLine fd str ++ tr' ++ tr)) ;;
                    {{Return (tr' ~~~ Flush fd :: ReadLine fd str ++ tr')}}
                  else
                    is  <- instream_of_list_ascii str <@> _ ;
                    ans <- parser is (inhabits 0) <@> _ ;
                    close is <@> _ ;;
                    let reply := match ans with
                                   | ERROR _ _ =>  e
                                   | OKAY _ _ a => f a
                                 end in
                    writeline fd reply rw_writeable (traceAfter tr' tr (fun t => ReadLine fd str ++ t)) <@> _;;
                    flush fd (traceAfter tr' tr (fun t => WroteString fd reply ++ ReadLine fd str ++ t)) rw_writeable <@> _;;
                    {{self (tr' ~~~ Flush fd :: WroteString fd reply ++ ReadLine fd str ++ tr')}})
                [nil]%inhabited;
      {{Return lt}}); try clear self; simpl char in *.
    unfold traceAfter, traceCombine. rsep fail auto.
    solve [ rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine, ccorrect; rsep ltac:(norm_list) auto; cut_pure; subst; constructor; auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    unfold traceAfter, traceCombine. rsep fail auto.
    instantiate (1 := tr ~~ tr' ~~ x1 :~~ (stream_elts is) in [x1 = str] * handle fd * [ecorrect fd tr'] * traced (ReadLine fd x1 ++ tr' ++ tr)). sep fail auto. (** Should be able to solve this? **)
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    rsep fail auto.
    unfold ans_str_correct, okaystr, okay, errorstr, error.
    instantiate (1 := tr ~~ tr' ~~ x1 :~~ (stream_elts is) in
      traced (ReadLine fd x1 ++ tr' ++ tr) * handle fd * [ecorrect fd tr'] * [x1 = str] *
        [parses grammar (nthtail x1 0) (match ans with
                                          | OKAY c m v => @Okay AsciiCharset _ c v (nthtail x1 m)
                                          | ERROR c _ => @Error AsciiCharset _ c
                                        end)]).
    cbv zeta. rsep fail auto. destruct ans; rsep fail auto. unfold Parsec.char in *. simpl char in *.
    assert (n + 0 = n). omega. rewrite H6. rewrite H1 in H4. rewrite (pack_injective H4). sep fail auto. (** We don't handle Exists yet **)
    unfold Parsec.char in *; simpl char in *. rewrite H1 in H4. rewrite (pack_injective H4). rsep fail auto.
    (** Solvable with some additional instramentation, unfolding of char **)

    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    unfold traceAfter, traceCombine. rsep fail auto.
    instantiate (1 := (tr' ~~ x1 :~~ (stream_elts is) in [ecorrect fd tr'] * [x1 = str] *
      [parses grammar (nthtail x1 0) match ans with
                                        | OKAY c m v => @Okay AsciiCharset _ c v (nthtail x1 m)
                                        | ERROR c _ => @Error AsciiCharset _ c
                                      end])%hprop).
    cbv zeta. subst. rsep fail auto.
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    unfold traceAfter, traceCombine; rsep fail auto.
    simpl. norm_list. rsep fail auto. cut_pure.
      eapply ConsCorrect; auto.
      instantiate (1 := match ans with
                          | OKAY c m v => @Okay AsciiCharset _ c v (nthtail x0 m)
                          | ERROR c _ => @Error AsciiCharset t c
                        end). destruct ans; auto.
      destruct ans; rewrite H2 in *; trivial.
    solve [ unfold traceAfter, traceCombine; rsep fail auto ].
    unfold traceAfter, traceCombine; rsep ltac:(norm_list) auto; cut_pure; constructor.
    solve [ unfold traceCombine; rsep fail auto ].
    solve [ unfold traceCombine; rsep fail auto ].
    solve [ unfold traceCombine; rsep fail auto ].
  Qed.
End TcpEvalServerParams.

Module uprefix_params := UdpEvalServerParams PrefixServer.
Module tprefix_params := TcpEvalServerParams PrefixServer.
Module sprefix_params := TcpEvalServerParams PrefixServer.

Module umes  := UdpServer.ExecImpl uprefix_params.
Module tmes' := TcpServer.ADD_STATE(tprefix_params).
Module tmes  := TcpServer.ExecImpl(tmes').
Module smes' := SslServer.ADD_STATE(sprefix_params).
Module smes  := SslServer.ExecImpl(smes').

Definition udp := umes.main.
Definition tcp := tmes.main.
Definition ssl := smes.main.


(** * Iteration: Bounded Loops *)

(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(* -------------------------------------------------------------------------- *
 *                     Vellvm - the Verified LLVM project                     *
 *                                                                            *
 *     Copyright (c) 2017 Steve Zdancewic <stevez@cis.upenn.edu>              *
 *                                                                            *
 *   This file is distributed under the terms of the GNU General Public       *
 *   License as published by the Free Software Foundation, either version     *
 *   3 of the License, or (at your option) any later version.                 *
 ---------------------------------------------------------------------------- *)

(* ################################################################# *)
(** * Bounded iterators *)

Require Import NArith FunctionalExtensionality.

Set Implicit Arguments.

Module Iter.

Section ITERATION.

Variables A B: Type.
Variable step: A -> B + A.

Definition num_iterations := 1000000000000%N.

Open Scope N_scope.

Definition iter_step (x: N)
                     (next: forall y, y < x -> A -> option B)
                     (s: A) : option B :=
  match N.eq_dec x N.zero with
  | left EQ => None
  | right NOTEQ =>
      match step s with
      | inl res => Some res
      | inr s'  => next (N.pred x) (N.lt_pred_l x NOTEQ) s'
      end
  end.

Definition iter: N -> A -> option B := Fix N.lt_wf_0 _ iter_step.
Definition iterate := iter num_iterations.

Variable P: A -> Prop.
Variable Q: B -> Prop.

Hypothesis step_prop:
  forall a : A, P a ->
  match step a with inl b => Q b | inr a' => P a' end.

Lemma iter_prop:
  forall n b a, P a -> iter n a = Some b -> Q b.
Proof.
  intros n b. pattern n. apply (well_founded_ind N.lt_wf_0).
  intros until 2. rewrite (Fix_eq N.lt_wf_0 _ iter_step).
  unfold iter_step at 1. destruct (N.eq_dec _ _).
  discriminate 1. specialize (step_prop H0).
  destruct (step a).
    inversion 1; subst b0; exact step_prop.
    apply H; auto. apply N.lt_pred_l; auto.
  intros. f_equal.
  apply functional_extensionality_dep. intro.
  apply functional_extensionality_dep. auto.
Qed.

Lemma iterate_prop:
  forall a b, iterate a = Some b -> P a -> Q b.
Proof.
  intros. apply iter_prop with num_iterations a; assumption.
Qed.

End ITERATION.

End Iter.


(** This file implements rewriting using lemmas.
 **)
Require Import Coq.omega.Omega.
Require Import Coq.Classes.Morphisms.
Require Import Coq.PArith.BinPos.
Require Import Coq.Relations.Relations.
Require Import Coq.FSets.FMapPositive.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.VarsToUVars.
Require Import MirrorCore.Instantiate.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.RTac.CoreK.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprTac.
Require Import MirrorCore.Lambda.ExprUnify.
Require Import MirrorCore.Lambda.RewriteRelations.
Require Import MirrorCore.Lambda.Rewrite.Core.

Set Implicit Arguments.
Set Strict Implicit.
Set Printing Universes.

Set Suggest Proof Using.

(** TODO(gmalecha): Move to EnvI or ExtLib.Data.HList **)
Polymorphic Lemma nth_error_get_hlist_nth_appR'
: forall {T : Type} (F : T -> Type) ls u v,
    nth_error_get_hlist_nth F ls u = Some v ->
    forall ls' : list T,
    exists v' : hlist F (ls' ++ ls) -> F (projT1 v),
      nth_error_get_hlist_nth F (ls' ++ ls) (u + length ls') = Some (existT _ (projT1 v) v') /\
      forall a b,
        projT2 v a = v' (hlist_app b a).
Proof using.
  induction ls'.
  { simpl.
    replace (u + 0) with u by omega.
    destruct v. eexists; split; eauto.
    simpl. intros.
    rewrite (hlist_eta b). reflexivity. }
  { simpl.
    replace (u + S (length ls')) with (S (u + length ls')) by omega.
    destruct IHls' as [ ? [ ? ? ] ].
    rewrite H0. eexists; split; eauto.
    simpl. intros.
    rewrite (hlist_eta b). simpl. eauto. }
Qed.

(** TODO: Move **)
Polymorphic Lemma forall_hlist_nil : forall T (F : T -> Type) (P : hlist F nil -> Prop),
    (forall x, P x) <-> P Hnil.
Proof using.
  intros. split. eauto. intros. rewrite hlist_eta. assumption.
Qed.

Polymorphic Lemma forall_hlist_cons : forall T (F : T -> Type) t ts (P : hlist F (t :: ts) -> Prop),
    (forall x, P x) <-> (forall x xs, P (Hcons x xs)).
Proof using.
  intros. split. eauto. intros. rewrite hlist_eta. eapply H.
Qed.

Section setoid.
  Context {typ : Set}.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  (** TODO(gmalecha): This is not necessary *)
  Context {RelDec_eq_typ : RelDec (@eq typ)}.
  Context {RelDec_Correct_eq_typ : RelDec_Correct RelDec_eq_typ}.

  Local Existing Instance Subst_ctx_subst.
  Local Existing Instance SubstOk_ctx_subst.
  Local Existing Instance SubstUpdate_ctx_subst.
  Local Existing Instance SubstUpdateOk_ctx_subst.
  Local Existing Instance Expr_expr.
  Local Existing Instance ExprOk_expr.

  (** TODO: Move **)
  Lemma pctxD_iff : forall ctx (cs : ctx_subst ctx) cD P Q,
      pctxD cs = Some cD ->
      (forall us vs, P us vs <-> Q us vs) ->
      forall us vs,
        cD P us vs <-> cD Q us vs.
  Proof using.
    intros.
    split; eapply Ap_pctxD; eauto; eapply Pure_pctxD; eauto; intros; eapply H0; eauto.
  Qed.

  (* TODO(gmalecha): Wrap all of this up in a type class?
   * Why should it be different than Expr?
   *)
  Variable Rbase : Set.
  Variable Rbase_eq : Rbase -> Rbase -> bool.
  Hypothesis Rbase_eq_ok : forall a b, Rbase_eq a b = true -> a = b.

  Local Notation "'R'" := (R typ Rbase).

  Variable RbaseD : Rbase -> forall t : typ, option (typD t -> typD t -> Prop).

  Hypothesis RbaseD_single_type
  : forall r t1 t2 rD1 rD2,
      RbaseD r t1 = Some rD1 ->
      RbaseD r t2 = Some rD2 ->
      t1 = t2.

  Definition func_sdec (a b : func) : bool :=
    match sym_eqb a b with
    | Some x => x
    | _ => false
    end.

  Definition expr_sdec : expr typ func -> expr typ func -> bool :=
    @expr_eq_sdec typ func _ func_sdec.

  Lemma expr_sdec_sound
  : forall a b : expr typ func, expr_sdec a b = true -> a = b.
  Proof using RSymOk_func RelDec_Correct_eq_typ.
    eapply expr_eq_sdec_ok; eauto.
    unfold func_sdec.
    intros. generalize (sym_eqbOk a b); eauto with typeclass_instances.
    destruct (sym_eqb a b); intros; subst; auto.
    inversion H.
  Qed.

  Section core_rewrite.
    (* This is the implementation of rewriting a single lemma *)

    Require Import MirrorCore.RTac.SolveK.

    (** TODO(gmalecha): This is not a nice interface because it is not
     ** a standard rewriter for two reasons:
     ** 1) It assumes that tvs' = nil, and
     ** 2) It assumes that the relation is the same as the relation for
     **    the lemma.
     **)
    Definition core_rewrite (lem : rw_lemma typ func Rbase)
               (tac : rtacK typ (expr typ func))
    : expr typ func ->
      forall c : Ctx typ (expr typ func),
        ctx_subst c -> option (expr typ func * ctx_subst c) :=
        match typeof_expr nil lem.(vars) lem.(concl).(lhs) with
        | None => fun _ _ _ => None
        | Some t =>
          fun e ctx cs =>
           let ctx' := CExs ctx lem.(vars) in
           let cs' : ctx_subst ctx' := ExsSubst cs (amap_empty _) in
           let (tus,tvs) := getEnvs ctx in
           let nus := length tus in
           let tus' := tus ++ lem.(vars) in
           match
             exprUnify 10 tus' tvs 0 (vars_to_uvars 0 nus lem.(concl).(lhs))
                       e t cs'
           with
           | None => None
           | Some cs'' =>
             let prems :=
                 List.map (fun e => GGoal (vars_to_uvars 0 nus e)) lem.(premises)
             in
             match
               (SOLVEK tac) ctx' cs'' (GConj_list prems)
             with
             | Solved cs''' =>
               match cs''' in ctx_subst ctx
                     return match ctx with
                            | CExs z _ => option (expr typ func * ctx_subst z)
                            | _ => unit
                            end
               with
               | ExsSubst cs'''' sub =>
		 if amap_is_full (length lem.(vars)) sub then
                   let res :=
                       instantiate (fun u => amap_lookup u sub) 0
                                   (vars_to_uvars 0 nus lem.(concl).(rhs))
                   in
                   Some (res, cs'''')
                 else
                   None
               | _ => tt
               end
             | _ => None
             end
           end
        end.

    (** TODO: Move **)
    Lemma lambda_exprD_weakenV
    : forall (tus tvs : tenv typ) (e : expr typ func) (t : typ)
             (val : exprT tus tvs (typD t)) (tvs' : list typ),
        lambda_exprD tus tvs t e = Some val ->
        exists val' : exprT tus (tvs ++ tvs') (typD t),
          lambda_exprD tus (tvs ++ tvs') t e = Some val' /\
          (forall (us : hlist typD tus) (vs : hlist typD tvs)
                  (vs' : hlist typD tvs'),
              val us vs = val' us (hlist_app vs vs')).
    Proof using RSymOk_func RTypeOk_typD Typ2Ok_Fun.
      intros.
      generalize (@exprD_weakenV typ _ (expr typ func) _ _ tus tvs tvs' e t val H).
      eauto.
    Qed.

    (** TODO: Move **)
    Lemma lambda_exprD_weakenU
    : forall (tus tvs : tenv typ) (e : expr typ func) (t : typ)
             (val : exprT tus tvs (typD t)) (tus' : list typ),
        lambda_exprD tus tvs t e = Some val ->
        exists val' : exprT (tus ++ tus') tvs (typD t),
          lambda_exprD (tus ++ tus') tvs t e = Some val' /\
          (forall (us : hlist typD tus) (vs : hlist typD tvs)
                  (us' : hlist typD tus'),
              val us vs = val' (hlist_app us us') vs).
    Proof using RSymOk_func RTypeOk_typD Typ2Ok_Fun.
      intros.
      generalize (@exprD_weakenU typ _ (expr typ func) _ _ tus tus' tvs e t val H).
      eauto.
    Qed.

    Local Instance Subst_amap T : Subst (amap T) T :=
      FMapSubst.SUBST.Subst_subst T.
    Local Instance SubstOk_amap : SubstOk (amap (expr typ func)) typ (expr typ func) :=
      @FMapSubst.SUBST.SubstOk_subst typ _ (expr typ func) _.

    Opaque instantiate.

    Lemma core_rewrite_lemma
    : forall (ctx : Ctx typ (expr typ func)) (t0 : typ)
               (x12 : amap (expr typ func)) (x13 : ctx_subst ctx)
               (l : list typ) (y0 : exprT (getUVars ctx) l (typD t0)),
        WellFormed_entry x13 (length l) x12 ->
        forall (e : expr typ func) (t : tenv typ)
               (y3 : exprT (getUVars ctx ++ l) t Prop)
               (x5 : hlist (fun t1 : typ => exprT (getUVars ctx) t (typD t1)) l),
          amap_substD (getUVars ctx ++ l) t x12 = Some y3 ->
          amap_is_full (length l) x12 = true ->
          (forall (us : hlist typD (getUVars ctx)) (vs : hlist typD t),
              let us' :=
                  hlist_map
                    (fun (t1 : typ) (x : exprT (getUVars ctx) t (typD t1)) => x us vs) x5
              in
              y3 (hlist_app us us') vs) ->
          lambda_exprD (getUVars ctx) l t0 e = Some y0 ->
          exists e'D : exprT (getUVars ctx) t (typD t0),
            lambda_exprD (getUVars ctx) t t0
                   (instantiate (fun u : ExprI.uvar => amap_lookup u x12) 0
                                (vars_to_uvars 0 (length (getUVars ctx)) e)) =
            Some e'D /\
            (forall (us : hlist typD (getUVars ctx)) (vs : hlist typD t),
                e'D us vs =
                y0 us
                   (hlist_map
                      (fun (t1 : typ) (x6 : exprT (getUVars ctx) t (typD t1)) =>
                         x6 us vs) x5)).
    Proof using RType_typD RTypeOk_typD RSymOk_func Typ2Ok_Fun.
      intros ctx t0 x12 x13 l y0 H40 e t y3 x5 Hamap_substD H4 H H13.
      generalize (@vars_to_uvars_sound typ (expr typ func) _ _ _ _ _ _ _ e nil t0 l _ H13).
      destruct 1 as [ ? [ ? ? ] ].
      eapply ExprI.exprD_weakenV with (tvs':=t) in H0; eauto with typeclass_instances.
      destruct H0 as [ ? [ ? ? ] ].
      destruct (@instantiate_sound typ (expr typ func) _ _ _ (getUVars ctx++l) t
                                   (fun u : ExprI.uvar => amap_lookup u x12)
                                   (vars_to_uvars 0 (length (getUVars ctx)) e) nil t0 x0 y3).
      { generalize (@sem_preserves_if_substD (amap (expr typ func)) typ (expr typ func) RType_typD Expr_expr _ _).
        simpl. intro. eapply H3.
        2: eapply Hamap_substD.
        eapply WellFormed_entry_WellFormed_pre_entry in H40.
        destruct H40. assumption. }
      { eassumption. }
      { destruct H3.
        eapply exprD_strengthenU_multi in H3.
        2: eauto with typeclass_instances.
        { destruct H3 as [ ? [ ? ? ] ].
          eexists; split; try eassumption.
          intros.
          specialize (H us vs).
          specialize (H5 _ _ Hnil H).
          simpl in *.
          symmetry.
          etransitivity; [ eapply (H1 _ _ Hnil) | ].
          etransitivity; [ eapply H2 | ].
          etransitivity; [ eapply H5 | ].
          eapply H6. }
        { intros.
          clear H2 H1 H3 H5 H.
          match goal with
          | |- ?X = _ => consider X; try reflexivity; intro
          end.
          exfalso.
          eapply mentionsU_instantiate in H.
          assert (amap_lookup (length (getUVars ctx) + u) x12 <> None).
          { clear - H4 H40 H6.
            destruct H40.
            clear H0.
            red in H.
            destruct H as [ ? [ ? ? ] ].
            clear H H1.
            generalize dependent (length (getUVars ctx)).
            generalize dependent (length l).
            intros.
            eapply pigeon_principle; eauto. }
          destruct H.
          { destruct H. eauto. }
          { destruct H. destruct H. destruct H as [ ? [ ? ? ] ].
            destruct H40.
            consider (amap_lookup (length (getUVars ctx) + u) x12); intros; try congruence.
            eapply FMapSubst.SUBST.normalized_fmapsubst in H1.
            3: eapply H.
            cut (true = false); [ clear; intros; congruence | ].
            rewrite <- H3. rewrite <- H1. reflexivity.
            destruct H5. assumption. } } }
    Qed.

    (* TODO(gmalecha): This is not a nice interface! *)
    Theorem core_rewrite_sound
    : forall ctx (cs : ctx_subst ctx),
        let tus := getUVars ctx in
        let tvs := getVars ctx in
        forall l0 r0 e e' cs',
          WellFormed_rtacK r0 ->
          core_rewrite l0 r0 e cs = Some (e', cs') ->
          WellFormed_ctx_subst cs ->
          WellFormed_ctx_subst cs' /\
          (forall (Hlem : lemmaD (rw_conclD RbaseD) nil nil l0)
                  (Hrtac :           rtacK_sound r0),
           forall (t : typ) (rD : typD t -> typD t -> Prop),
              RD RbaseD (rel (concl l0)) t = Some rD ->
              match pctxD cs with
              | Some _ =>
                match lambda_exprD tus tvs t e with
                | Some eD =>
                  match pctxD cs' with
                  | Some csD' =>
                    match lambda_exprD tus tvs t e' with
                    | Some eD' =>
                      SubstMorphism cs cs' /\
                      (forall (us : hlist typD (getAmbientUVars ctx))
                              (vs : hlist typD (getAmbientVars ctx)),
                          csD'
                            (fun (us0 : hlist typD (getUVars ctx))
                                 (vs0 : hlist typD (getVars ctx)) =>
                               rD (eD us0 vs0) (eD' us0 vs0)) us vs)
                    | None => False
                    end
                  | None => False
                  end
                | None => True
                end
              | None => True
              end).
    Proof using RelDec_Correct_eq_typ RbaseD_single_type
          RTypeOk_typD RSymOk_func Typ2Ok_Fun.
      Opaque vars_to_uvars.
      unfold core_rewrite. generalize dependent 10.
      simpl.
      intros.
      consider (typeof_expr nil l0.(vars) l0.(concl).(lhs)); intros.
      { rewrite getEnvs_getUVars_getVars in *.
        match goal with
        | H : match ?X with _ => _ end = _ |- _ =>
          consider X; intros
        end; try match goal with
                 | H : None = Some _ |- _ => exfalso ; clear - H ; inversion H
                 end.
        assert (WellFormed_rtacK (SOLVEK r0)).
        { apply WF_SOLVEK. assumption. }
        clear H; rename H4 into H.
        match goal with
        | Hrt : WellFormed_rtacK ?X , _ : match ?X ?C ?CS ?G with _ => _ end = _ |- _ =>
          specialize (@Hrt C CS G _ eq_refl)
        end.
        match goal with
        | Hrt : rtacK_spec_wf _ _ ?X , H : match ?Y with _ => _ end = _ |- _ =>
          replace Y with X in H ; [ destruct X eqn:?; intros | f_equal ]
        end; try congruence.
        rewrite (ctx_subst_eta c0) in H3.
        repeat match goal with
               | H : match ?X with _ => _ end = _ |- _ =>
                 let H' := fresh in
                 destruct X eqn:H'; [ | solve [ exfalso; clear - H3; inversion H3 ] ]
               end.
        inv_all. subst.
        destruct (@exprUnify_sound (ctx_subst (CExs ctx (vars l0))) typ func _ _ _ _ _ _ _ _ _ _ n
                                   _ _ _ _ _ _ _ nil H2).
        { constructor; eauto using WellFormed_entry_amap_empty. }
        split.
        { red in H.
          assert (WellFormed_Goal (getUVars (CExs ctx (vars l0)))
                                  (getVars (CExs ctx (vars l0)))
                                  (GConj_list
                                     (map
                                        (fun e : expr typ func =>
                                           GGoal (vars_to_uvars 0 (length (getUVars ctx)) e))
                                        (premises l0)))).
          { eapply WellFormed_Goal_GConj_list. clear.
            induction (premises l0); simpl.
            - constructor.
            - constructor; eauto. constructor. }
          specialize (H H6 H3); clear H6.
          rewrite (ctx_subst_eta c0) in H.
          inv_all. auto. }
        clear H. intro. intro H.
        assert (rtacK_sound (SOLVEK r0)).
        { apply SOLVEK_sound. assumption. }
        clear H; rename H6 into H.
        intros.
        destruct (pctxD cs) eqn:HpctxDcs; trivial.
        destruct (lambda_exprD (getUVars ctx) (getVars ctx) t0 e) eqn:Hlambda_exprDe; trivial.
        simpl in *.
        eapply lemmaD_lemmaD' in Hlem. forward_reason.
        eapply lemmaD'_weakenU with (tus':=getUVars ctx) in H7;
          eauto using ExprOk_expr, rw_concl_weaken.
        simpl in H7. forward_reason.
        unfold lemmaD' in H7.
        forwardy. inv_all. subst.
        unfold rw_conclD in H10.
        forwardy. inv_all; subst.
        assert (t0 = t).
        { revert H0.
          assert (y1 = t0).
          { eapply RD_single_type; eauto. }
          subst t0.
          intro.
          eapply ExprFacts.typeof_expr_weaken with (tus':=getUVars ctx) (tvs':=nil) in H0; eauto.
          simpl in H0. rewrite H10 in H0. inv_all; auto. }
        subst.
        assert (y1 = t).
        { revert H13. revert H6.
          intros. eapply RD_single_type; eauto. }
        subst t. rename y1 into t.
        generalize (fun tus tvs e t => @ExprI.exprD_conv typ _ (expr typ func)
                                          _ tus tus (tvs ++ nil) tvs e t eq_refl
                                          (eq_sym (app_nil_r_trans _))). simpl.
        intro Hlambda_exprD_conv.
        rewrite Hlambda_exprD_conv in H12. autorewrite_with_eq_rw_in H12.
        rewrite Hlambda_exprD_conv in H11. autorewrite_with_eq_rw_in H11.
        forwardy. inv_all. subst.

        generalize (@vars_to_uvars_sound typ (expr typ func) _ _ _ _ _ _ _ _ nil _ _ _ H11).
        simpl. destruct 1 as [ ? [ Hlambda_exprDe_subst ? ] ].
        eapply lambda_exprD_weakenV with (tvs':=getVars ctx) in Hlambda_exprDe_subst; eauto.
        simpl in Hlambda_exprDe_subst. forward_reason.
        intros; subst.
        replace (length (getUVars ctx ++ t :: nil))
           with (S (length (getUVars ctx))) in H15
             by (rewrite app_length; simpl; omega).
        eapply lambda_exprD_weakenU
          with (tus':=l0.(vars)) in Hlambda_exprDe; eauto.
        destruct (drop_exact_append_exact (vars l0) (getUVars ctx)) as [ ? [ Hx ? ] ].
        rewrite Hx in *; clear Hx.
        destruct (pctxD_substD H1 HpctxDcs) as [ ? [ Hx ? ] ].
        rewrite Hx in *; clear Hx.
        destruct Hlambda_exprDe as [ ? [ Hx ? ] ].
        specialize (H5 _ _ _ H15 Hx eq_refl).
        clear Hx.
        forward_reason.
        generalize (pctxD_SubstMorphism_progress H5).
        simpl. rewrite HpctxDcs.
        intro Hx; specialize (Hx _ eq_refl). destruct Hx.
        red in H.
        replace (getUVars ctx ++ vars l0)
           with (getUVars (CExs ctx (vars l0)))
             in Heqr
             by reflexivity.
        eapply (H (CExs ctx (vars l0))) in Heqr. red in Heqr.
        destruct Heqr; eauto.
        { clear. induction (premises l0); simpl. constructor.
          destruct l; simpl. constructor.
          constructor. constructor. eauto. }
        rewrite H22 in *.
        assert (exists Ps,
                   goalD (getUVars ctx ++ vars l0) (getVars ctx)
                         (GConj_list
                            (map
                               (fun e2 : expr typ func =>
                                  GGoal (vars_to_uvars 0 (length (getUVars ctx)) e2))
                               (premises l0))) = Some Ps /\
                   forall (us : hlist typD (getUVars ctx)) us' vs,
                     Ps (hlist_app us us') vs <->
                     Forall (fun y => y us (hlist_app us' Hnil)) y).
        { revert H7.
          destruct l0. simpl in *.
          clear - RTypeOk_typD RSymOk_func Typ2Ok_Fun.
          intros.
          cut (exists Ps : exprT (getUVars ctx ++ vars) (getVars ctx) Prop,
                  goalD (getUVars ctx ++ vars) (getVars ctx)
                        (GConj_list_simple
                           (map
                              (fun e2 : expr typ func =>
                                 GGoal (vars_to_uvars 0 (length (getUVars ctx)) e2))
                              premises)) = Some Ps /\
                  (forall (us : hlist typD (getUVars ctx)) (us' : hlist typD vars)
                          (vs : hlist typD (getVars ctx)),
                      Ps (hlist_app us us') vs <->
                      Forall
                        (fun
                            y0 : hlist typD (getUVars ctx) ->
                                 hlist typD (vars ++ nil) -> Prop =>
                            y0 us (hlist_app us' Hnil)) y)).
          { destruct (goalD_GConj_list_GConj_list_simple
                        (getUVars ctx ++ vars) (getVars ctx)
                        (map (fun e2 : expr typ func =>
                                GGoal (vars_to_uvars 0 (length (getUVars ctx)) e2))
                           premises)).
            { intros; forward_reason; congruence. }
            { intros; forward_reason.
              inv_all. subst. eexists; split; eauto.
              intros.
              rewrite <- H1. eapply H.
              reflexivity. reflexivity. } }
          revert H7. revert y.
          induction premises; simpl; intros.
          { eexists; split; eauto.
            simpl. inv_all. subst.
            split; eauto. }
          { simpl in *.
            forwardy. inv_all. subst.
            unfold exprD_typ0 in H.
            simpl in H. forwardy.
            generalize (@vars_to_uvars_sound typ (expr typ func) _ _ _ _ _ _ _ _ nil _ _ _ H).
            intro. forward_reason.
            unfold propD, exprD_typ0.
            simpl in H2.
            eapply lambda_exprD_weakenV
              with (tvs':=getVars ctx)
                in H2; eauto.
            forward_reason. simpl in H2.
            generalize (@exprD_conv typ _ (expr typ func) _); eauto. simpl.
            intro Hx.
            rewrite Hx
               with (pfu:=f_equal _ (eq_sym (app_nil_r_trans _))) (pfv:=eq_refl)
                 in H2.
            autorewrite_with_eq_rw_in H2.
            forwardy.
            rewrite H2.
            specialize (IHpremises _ H0).
            forward_reason. rewrite H6.
            eexists; split; eauto. simpl.
            intros.
            inv_all. subst.
            intros. rewrite Forall_cons_iff.
            rewrite <- (H7 _ _ vs).
            autorewrite with eq_rw.
            specialize (H3 us (hlist_app us' Hnil) Hnil).
            simpl in *.
            rewrite H3; clear H3.
            erewrite (H4 (hlist_app us (hlist_app us' Hnil)) Hnil vs); clear H4.
            simpl. rewrite hlist_app_nil_r.
            unfold f_equal.
            autorewrite with eq_rw.
            clear.
            generalize (app_nil_r_trans vars).
            generalize dependent (vars ++ nil).
            intros; subst. reflexivity. } }
        destruct H25 as [ ? [ Hx ? ] ].
        change_rewrite Hx in H24; clear Hx.
        forwardy.
        rewrite (ctx_subst_eta c0) in H24.
        simpl in H24.
        forwardy. rewrite H27.
        inv_all; subst.
        destruct (amap_substD_amap_empty (getUVars ctx ++ vars l0)
                                         (getVars ctx)) as [ ? [ Hx ? ] ].
          change_rewrite Hx in H5; clear Hx.
        rewrite HpctxDcs in H5.
        simpl in *.
        destruct (drop_exact_append_exact l0.(vars) (getUVars ctx)) as [ ? [ Hx ? ] ];
          rewrite Hx in *; clear Hx.
        destruct H26.
        inv_all. subst.
        forwardy.
        repeat match goal with
               | H : ?X = _ , H' : ?X = _ |- _ => rewrite H in H'
               end.
        forward_reason; inv_all; subst.
        simpl in *.
        rewrite H5 in *.
        rewrite H3 in *.
        rewrite H27 in *.
        rewrite H24 in *.
        inv_all.
        forwardy.
        generalize H24. intro Hamap_substD.
        eapply subst_getInstantiation in H24;
          eauto using WellFormed_entry_WellFormed_pre_entry
                 with typeclass_instances.
        destruct H24.
        assert (exists e'D,
                   lambda_exprD (getUVars ctx) (getVars ctx) t
                          (instantiate (fun u : ExprI.uvar => amap_lookup u x12)
                                       0 (vars_to_uvars 0 (length (getUVars ctx)) l0.(concl).(rhs))) = Some e'D /\
                   forall us vs,
                     e'D us vs =
                     y0 us (hlist_map
                              (fun (t : typ) (x6 : exprT (getUVars ctx) (getVars ctx) (typD t)) =>
                                 x6 us vs) x5)).
        { eapply core_rewrite_lemma; eauto. }
        destruct H20 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
        split.
        { etransitivity; eassumption. }
        intros.
        eapply pctxD_substD' with (us:=us) (vs:=vs) in H38; eauto with typeclass_instances.
        gather_facts.
        eapply pctxD_SubstMorphism; [ | | eauto | ]; eauto.
        gather_facts.
        eapply pctxD_SubstMorphism; [ | | eauto | ]; eauto.
        gather_facts.
        eapply Pure_pctxD; eauto. intros.
        specialize (H20 us0 vs0).
        specialize (H6 us0 vs0).
        generalize dependent (hlist_map
           (fun (t : typ) (x6 : exprT (getUVars ctx) (getVars ctx) (typD t)) =>
            x6 us0 vs0) x5); simpl; intros.
        rewrite H20; clear H20.
        generalize H6.
        eapply H24 in H6; clear H24.
        specialize (H29 us0 h).
        clear - H19 H16 H14 H17 H25 H28 H21 H9 H18 H22 H23 H26 H6 H8 H29.
        eapply H9 in H8; clear H9.
        rewrite foralls_sem in H8.
        specialize (H8 h).
        setoid_rewrite impls_sem in H8.
        rewrite Quant._forall_sem in H26.
        repeat match goal with
               | H : (forall x : hlist _ _ , _) , H' : hlist _ _ |- _ =>
                 specialize (H H')
               end.
        specialize (H16 (hlist_app us0 h) Hnil vs0).
        specialize (H21 (hlist_app us0 h) vs0).
        rewrite H19; clear H19.
        rewrite H29 in *; clear H29.
        destruct H21; auto.
        specialize (H0 Hnil). simpl in H0.
        rewrite <- H0; clear H0.
        simpl in *.
        rewrite <- H16; clear H16.
        rewrite <- H14; clear H14.
        simpl.
        revert H8.
        instantiate (1:= us0).
        autorewrite_with_eq_rw.
        rewrite hlist_app_nil_r.
        autorewrite_with_eq_rw.
        intros. apply H8; clear H8.
        eapply List.Forall_map.
        eapply H26 in H0; clear H26.
        eapply H25 in H0; clear H25.
        revert H0.
        eapply Forall_impl. clear.
        intros.
        rewrite <- hlist_app_nil_r.
        assumption. }
      { exfalso; clear - H2; inversion H2. }
    Time Qed.

    Theorem core_rewrite_soundX
    : forall ctx (cs : ctx_subst ctx),
        let tus := getUVars ctx in
        let tvs := getVars ctx in
        forall l0 r0 e e' cs'
          (Hlem  : lemmaD (rw_conclD RbaseD) nil nil l0)
          (Hrtac : rtacK_sound r0),
          core_rewrite l0 r0 e cs = Some (e', cs') ->
          WellFormed_ctx_subst cs ->
          WellFormed_ctx_subst cs' /\
          (forall (t : typ) (rD : typD t -> typD t -> Prop),
              RD RbaseD (rel (concl l0)) t = Some rD ->
              match pctxD cs with
              | Some _ =>
                match lambda_exprD tus tvs t e with
                | Some eD =>
                  match pctxD cs' with
                  | Some csD' =>
                    match lambda_exprD tus tvs t e' with
                    | Some eD' =>
                      SubstMorphism cs cs' /\
                      (forall (us : hlist typD (getAmbientUVars ctx))
                              (vs : hlist typD (getAmbientVars ctx)),
                          csD'
                            (fun (us0 : hlist typD (getUVars ctx))
                                 (vs0 : hlist typD (getVars ctx)) =>
                               rD (eD us0 vs0) (eD' us0 vs0)) us vs)
                    | None => False
                    end
                  | None => False
                  end
                | None => True
                end
              | None => True
              end).
    Proof using RelDec_Correct_eq_typ RbaseD_single_type
          RTypeOk_typD RSymOk_func Typ2Ok_Fun.
      Opaque vars_to_uvars.
      intros.
      eapply core_rewrite_sound in H; eauto using rtacK_sound_WellFormed_rtacK.
      forward_reason.
      split; eauto.
    Qed.

  End core_rewrite.

  (* This section implements the re-indexing operation
   * to run [rtac]'s from [mrw]. Note that the main thing to do
   * is extend the context with any extra variables and re-index
   * variables in the term since they are in the opposite order.
   *)
  Section reindexing.
    (* This has to do with converting expressions for tactics *)
    Let _lookupU (u : ExprI.uvar) : option (expr typ func) := None.
    Let _lookupV (under : nat) (above : nat) (v : ExprI.var)
    : option (expr typ func) :=
      Some (Var (if v ?[ ge ] under
                 then v - under
                 else v + above)).

    Definition expr_convert (u : nat) (above : nat)
    : expr typ func -> expr typ func :=
      expr_subst _lookupU (_lookupV u above) 0.

    Lemma expr_convert_sound
    : forall tus tvs tvs' e t eD,
        lambda_exprD tus (tvs ++ tvs') t e = Some eD ->
        exists eD',
          lambda_exprD tus (tvs' ++ tvs) t (expr_convert (length tvs) (length tvs') e) = Some eD' /\
          forall a b c,
            eD a (hlist_app b c) = eD' a (hlist_app c b).
    Proof using RSymOk_func RTypeOk_typD Typ2Ok_Fun.
      unfold expr_convert.
      intros.
      destruct (fun Hu Hv => @ExprI.expr_subst_sound
                    typ _ (expr typ func) Expr_expr _
                    _lookupU
                    (_lookupV (length tvs) (length tvs'))
                    0 e _ eq_refl nil
                    tus (tvs ++ tvs') tus (tvs' ++ tvs)
                    (fun us vs us' vs' =>
                       us = us' /\
                       let (_vs,_vs') := hlist_split _ _ vs in
                       let (__vs,__vs') := hlist_split _ _ vs' in
                       _vs = __vs' /\ _vs' = __vs) Hu Hv t _ eq_refl H).
      { simpl. clear.
        intros. eexists; split; eauto.
        intros. destruct H1; subst; auto. }
      { simpl. intros.
        autorewrite with exprD_rw. simpl.
        consider (u ?[ ge ] length tvs); intros.
        { eapply nth_error_get_hlist_nth_appR in H1; eauto.
          simpl in H1. forward_reason.
          eapply nth_error_get_hlist_nth_weaken with (ls':=tvs) in H1.
          simpl in H1.
          forward_reason. rewrite H1.
          rewrite type_cast_refl; eauto.
          eexists; split; eauto.
          unfold Rcast_val, Rcast, Relim. simpl.
          intros.
          revert H5.
          rewrite <- (hlist_app_hlist_split _ _ vs).
          rewrite <- (hlist_app_hlist_split _ _ vs').
          rewrite hlist_split_hlist_app.
          rewrite hlist_split_hlist_app.
          destruct 1.
          rewrite H3. rewrite <- H4.
          f_equal. tauto. }
        { assert (u < length tvs) by omega.
          eapply nth_error_get_hlist_nth_appL in H3.
          destruct H3. destruct H3.
          rewrite H3 in H1.
          assert (u + length tvs' >= length tvs') by omega.
          destruct H4 as [ ? [ ? ? ] ].
          eapply nth_error_get_hlist_nth_appR' in H4; simpl in H4.
          destruct H4 as [ ? [ ? ? ] ].
          rewrite H4.
          inv_all. subst. simpl.
          rewrite type_cast_refl; eauto.
          eexists; split; eauto.
          intros us vs us' vs'.
          rewrite <- (hlist_app_hlist_split _ _ vs).
          rewrite <- (hlist_app_hlist_split _ _ vs').
          rewrite hlist_split_hlist_app.
          rewrite hlist_split_hlist_app.
          destruct 1.
          simpl in *.
          rewrite H6. rewrite <- H7.
          unfold Rcast_val, Rcast; simpl. f_equal. tauto. } }
      { simpl in H0.
        destruct H0; eexists; split; eauto.
        intros. apply (H1 a (hlist_app b c) a (hlist_app c b) Hnil).
        split; auto.
        do 2 rewrite hlist_split_hlist_app.
        tauto. }
    Qed.

    (* This code starts to build the structure necessary for [rtac]
     *)
    Fixpoint wrap_tvs (tvs : tenv typ) (ctx : Ctx typ (expr typ func))
    : Ctx typ (expr typ func) :=
      match tvs with
      | nil => ctx
      | t :: tvs' => wrap_tvs tvs' (CAll ctx t)
      end.

    Fixpoint wrap_tvs_ctx_subst tvs ctx (cs : ctx_subst ctx)
    : ctx_subst (wrap_tvs tvs ctx) :=
      match tvs as tvs return ctx_subst (wrap_tvs tvs ctx) with
      | nil => cs
      | t :: tvs => wrap_tvs_ctx_subst _ (AllSubst cs)
      end.

    Fixpoint unwrap_tvs_ctx_subst T tvs ctx
    : ctx_subst (wrap_tvs tvs ctx) -> (ctx_subst ctx -> T) -> T :=
      match tvs as tvs
            return ctx_subst (wrap_tvs tvs ctx) -> (ctx_subst ctx -> T) -> T
      with
      | nil => fun cs k => k cs
      | t :: tvs => fun cs k =>
        @unwrap_tvs_ctx_subst T tvs (CAll ctx t) cs (fun z => k (fromAll z))
      end.

    (* TODO(gmalecha): This does not have a stand-alone soundness theorem,
     * which is problematic because it does some quite complex manipulation.
     *)
    Definition for_tactic
               (m : expr typ func ->
                    forall ctx : Ctx typ (expr typ func),
                      ctx_subst ctx -> option (expr typ func * ctx_subst ctx))
    : expr typ func -> mrw typ func (expr typ func) :=
      fun e tvs' ctx cs =>
        let under := length tvs' in
        let nvs := countVars ctx in
        let e' := expr_convert under nvs e in
        match
          m e' _ (@wrap_tvs_ctx_subst tvs' ctx cs)
        with
        | None => None
        | Some (v,cs') =>
          Some (expr_convert nvs under v,
                @unwrap_tvs_ctx_subst _ tvs' ctx cs' (fun x => x))
        end.

    (* TODO(gmalecha): This should go in a new file that implements
     * rewriting databases.
     *)
    Fixpoint using_rewrite_db'
             (ls : list (rw_lemma typ func Rbase * rtacK typ (expr typ func)))
    : expr typ func -> R ->
      forall ctx, ctx_subst ctx -> option (expr typ func * ctx_subst ctx) :=
      match ls with
      | nil => fun _ _ _ _ => None
      | (lem,tac) :: ls =>
        let res := using_rewrite_db' ls in
        let crw := core_rewrite lem tac in
        fun e r ctx cs =>
          if Req_dec Rbase_eq r lem.(concl).(rel) then
            match crw e _ cs with
            | None => res e r ctx cs
            | X => X
            end
          else res e r ctx cs
      end.

    Lemma using_rewrite_db'_sound
    : forall r ctx (cs : ctx_subst ctx),
        let tus := getUVars ctx in
        let tvs := getVars ctx in
        forall hints : list (rw_lemma typ func Rbase * rtacK typ (expr typ func)),
        Forall (fun lt =>
                  lemmaD (rw_conclD RbaseD) nil nil (fst lt) /\
                  rtacK_sound (snd lt)) hints ->
        forall e e' cs',
          @using_rewrite_db' hints e r ctx cs = Some (e', cs') ->
          WellFormed_ctx_subst cs ->
          WellFormed_ctx_subst cs' /\
          (forall (t : typ) (rD : typD t -> typD t -> Prop),
              RD RbaseD r t = Some rD ->
              match pctxD cs with
              | Some _ =>
                match lambda_exprD tus tvs t e with
                | Some eD =>
                  match pctxD cs' with
                  | Some csD' =>
                    match lambda_exprD tus tvs t e' with
                    | Some eD' =>
                      SubstMorphism cs cs' /\
                      (forall (us : hlist typD (getAmbientUVars ctx))
                              (vs : hlist typD (getAmbientVars ctx)),
                          csD'
                            (fun (us0 : hlist typD (getUVars ctx))
                                 (vs0 : hlist typD (getVars ctx)) =>
                                 rD (eD us0 vs0)
                                    (eD' us0 vs0)) us vs)
                    | None => False
                    end
                  | None => False
                  end
                | None => True
                end
              | None => True
              end).
    Proof using RSymOk_func RTypeOk_typD RbaseD_single_type Rbase_eq_ok RelDec_Correct_eq_typ Typ2Ok_Fun.
      induction 1.
      { simpl. inversion 1. }
      { simpl. intros. destruct x.
        assert (using_rewrite_db' l e r cs = Some (e',cs')
             \/ (r = l0.(concl).(rel) /\
                 core_rewrite l0 r0 e cs = Some (e',cs'))).
        { generalize (Req_dec_ok Rbase_eq Rbase_eq_ok r l0.(concl).(rel)).
          destruct (Req_dec Rbase_eq r l0.(concl).(rel)); eauto.
          intros. destruct (core_rewrite l0 r0 e cs); eauto. }
        clear H1. destruct H3; eauto.
        destruct H1. subst. clear IHForall H0.
        simpl in H. destruct H.
        revert H2. revert H3. revert H. revert H0.
        intros.
        eapply core_rewrite_sound in H3; eauto using rtacK_sound_WellFormed_rtacK.
        forward_reason. eauto. }
    Qed.

    Section using_prewrite_db.
      Variable phints : expr typ func -> R -> list (rw_lemma typ func Rbase * rtacK typ (expr typ func)).

      Definition using_prewrite_db' :=
        fun e r => using_rewrite_db' (phints e r) e r.

      Lemma using_prewrite_db_sound'
      : forall r ctx (cs : ctx_subst ctx),
          let tus := getUVars ctx in
          let tvs := getVars ctx in
          forall e e' cs',
            @using_prewrite_db' e r ctx cs = Some (e', cs') ->
            forall (Hrtac_wf : forall e r,
                       Forall (fun lt => WellFormed_rtacK (snd lt)) (phints e r)),
            WellFormed_ctx_subst cs ->
            WellFormed_ctx_subst cs' /\
            ((forall e r tus tvs t eD,
                 lambda_exprD tus tvs t e = Some eD ->
                 Forall (fun lt =>
                           lemmaD (rw_conclD RbaseD) nil nil (fst lt) /\
                           rtacK_sound (snd lt)) (phints e r)) ->
             (forall (t : typ) (rD : typD t -> typD t -> Prop),
                 RD RbaseD r t = Some rD ->
                 match pctxD cs with
                 | Some _ =>
                   match lambda_exprD tus tvs t e with
                   | Some eD =>
                     match pctxD cs' with
                     | Some csD' =>
                       match lambda_exprD tus tvs t e' with
                       | Some eD' =>
                         SubstMorphism cs cs' /\
                         (forall (us : hlist typD (getAmbientUVars ctx))
                                 (vs : hlist typD (getAmbientVars ctx)),
                             csD'
                               (fun (us0 : hlist typD (getUVars ctx))
                                    (vs0 : hlist typD (getVars ctx)) =>
                                  rD (eD us0 vs0)
                                     (eD' us0 vs0)) us vs)
                       | None => False
                       end
                     | None => False
                     end
                   | None => True
                   end
                 | None => True
                 end)).
      Proof using RSymOk_func RTypeOk_typD RbaseD_single_type
            Rbase_eq_ok RelDec_Correct_eq_typ Typ2Ok_Fun.
        simpl.
        unfold using_prewrite_db'.
        intros r ctx cs e. revert cs.
        cut (forall (cs : ctx_subst ctx) (e' : expr typ func) (cs' : ctx_subst ctx),
                using_rewrite_db' (phints e r) e r cs =
                Some (e', cs') ->
                (Forall
                   (fun lt : rw_lemma typ func Rbase * rtacK typ (expr typ func) =>
                      WellFormed_rtacK (snd lt)) (phints e r)) ->
                WellFormed_ctx_subst cs ->
                WellFormed_ctx_subst cs' /\
                ((forall (tus tvs : tenv typ)
                         (t : typ) (eD : exprT tus tvs (typD t)),
                     lambda_exprD tus tvs t e = Some eD ->
                     Forall
                       (fun
                           lt : lemma typ (expr typ func) (rw_concl typ func Rbase) *
                                rtacK typ (expr typ func) =>
                           lemmaD (rw_conclD RbaseD) nil nil (fst lt) /\ rtacK_sound (snd lt))
                       (phints e r)) ->
                 forall (t : typ) (rD : typD t -> typD t -> Prop),
                   RD RbaseD r t = Some rD ->
                   match pctxD cs with
                   | Some _ =>
                     match lambda_exprD (getUVars ctx) (getVars ctx) t e with
                     | Some eD =>
                       match pctxD cs' with
                       | Some csD' =>
                         match lambda_exprD (getUVars ctx) (getVars ctx) t e' with
                         | Some eD' =>
                           SubstMorphism cs cs' /\
                           (forall (us : hlist typD (getAmbientUVars ctx))
                                   (vs : hlist typD (getAmbientVars ctx)),
                               csD'
                                 (fun (us0 : hlist typD (getUVars ctx))
                                      (vs0 : hlist typD (getVars ctx)) =>
                                    rD (eD us0 vs0) (eD' us0 vs0)) us vs)
                         | None => False
                         end
                       | None => False
                       end
                     | None => True
                     end
                   | None => True
                   end)).
        { clear.
          intros; forward_reason.
          eapply H in H0; eauto.
          forward_reason. split; eauto.
          intros.
          eapply H2; eauto. }
        induction (phints e r).
        { inversion 1. }
        { simpl. intros.
          destruct a.
          assert (using_rewrite_db' l e r cs = Some (e',cs')
                  \/ (r = r0.(concl).(rel) /\
                      core_rewrite r0 r1 e cs = Some (e',cs'))).
          { generalize (Req_dec_ok Rbase_eq Rbase_eq_ok r r0.(concl).(rel)).
            destruct (Req_dec Rbase_eq r r0.(concl).(rel)); eauto.
            intros. destruct (core_rewrite r0 r1 e cs); eauto. }
          clear H.
          destruct H2.
          { eapply IHl in H; clear IHl; eauto.
            forward_reason. split; eauto.
            intros. eapply H2; eauto.
            intros. eapply H3 in H5; eauto. inversion H5; eauto.
            inversion H0; auto. }
          { forward_reason. subst.
            split.
            { eapply core_rewrite_sound in H2; eauto.
              forward_reason; eauto.
              inversion H0; trivial. }
            { intros. forward.
              specialize (H _ _ _ _ H5).
              inversion H; clear H; subst; forward_reason.
              eapply core_rewrite_sound in H1; eauto.
              forward_reason; eauto.
              eapply H7 in H3.
              revert H3.
              Cases.rewrite_all_goal.
              trivial.
              inversion H0; trivial. } } }
      Qed.

    End using_prewrite_db.

    Definition using_rewrite_db''
               (ls : list (rw_lemma typ func Rbase * rtacK typ (expr typ func)))
    : expr typ func -> R -> mrw typ func (expr typ func) :=
      let rw_db := using_rewrite_db' ls in
      fun e r => for_tactic (fun e => rw_db e r) e.

    Definition using_prewrite_db''
        (lems : expr typ func -> R -> list (rw_lemma typ func Rbase * rtacK typ (expr typ func)))
    : expr typ func -> R -> mrw typ func (expr typ func) :=
      fun e r =>
        for_tactic (fun e => using_rewrite_db' (lems e r) e r) e.

    Lemma getAmbientUVars_wrap_tvs : forall tvs ctx,
        getAmbientUVars (wrap_tvs tvs ctx) = getAmbientUVars ctx.
    Proof using.
      induction tvs; simpl. reflexivity.
      intros. rewrite IHtvs. reflexivity.
    Defined.

    Lemma getAmbientVars_wrap_tvs : forall tvs ctx,
        getAmbientVars (wrap_tvs tvs ctx) = getAmbientVars ctx.
    Proof using.
      induction tvs; simpl. reflexivity.
      intros. rewrite IHtvs. reflexivity.
    Defined.

    Lemma getVars_wrap_tvs : forall tvs' ctx,
        getVars (wrap_tvs tvs' ctx) = getVars ctx ++ tvs'.
    Proof using.
      induction tvs'; simpl; eauto.
      symmetry. eapply app_nil_r_trans.
      simpl. intros. rewrite IHtvs'. simpl.
      rewrite app_ass_trans. reflexivity.
    Defined.

    Lemma WellFormed_ctx_subst_unwrap_tvs
    : forall tvs' ctx ctx' (cs : ctx_subst _)
             (k : ctx_subst (Ctx_append ctx ctx') -> ctx_subst ctx),
        (forall cs, WellFormed_ctx_subst cs -> WellFormed_ctx_subst (k cs)) ->
        WellFormed_ctx_subst cs ->
        WellFormed_ctx_subst
          (@unwrap_tvs_ctx_subst (ctx_subst ctx) tvs' (Ctx_append ctx ctx') cs k).
    Proof using.
      induction tvs'; simpl; auto.
      intros. specialize (IHtvs' ctx (CAll ctx' a) cs).
      simpl in *. eapply IHtvs'; eauto.
      intros. eapply H. rewrite (ctx_subst_eta cs0) in H1.
      inv_all. assumption.
    Qed.

    Fixpoint unwrap_tvs_ctx_subst' (tvs : tenv typ) (ctx : Ctx typ (expr typ func))
    : ctx_subst (wrap_tvs tvs ctx) -> ctx_subst ctx :=
      match tvs as tvs return ctx_subst (wrap_tvs tvs ctx) -> ctx_subst ctx with
      | nil => fun X => X
      | t :: tvs => fun X => fromAll (unwrap_tvs_ctx_subst' tvs _ X)
      end.

    Theorem unwrap_tvs_ctx_subst_unwrap_tvs_ctx_subst'
    : forall T tvs ctx cs (k : _ -> T),
        k (@unwrap_tvs_ctx_subst' tvs ctx cs) =
        unwrap_tvs_ctx_subst tvs cs k.
    Proof using.
      induction tvs; simpl. auto.
      intros. rewrite <- IHtvs. reflexivity.
    Qed.

    Lemma getUVars_wrap_tvs
    : forall tvs' ctx, getUVars (wrap_tvs tvs' ctx) = getUVars ctx.
    Proof using.
      induction tvs'; simpl; auto.
      intros.  rewrite IHtvs'. reflexivity.
    Defined.

    Lemma WellFormed_ctx_subst_wrap_tvs : forall tvs' ctx (cs : ctx_subst ctx),
        WellFormed_ctx_subst cs ->
        WellFormed_ctx_subst (wrap_tvs_ctx_subst tvs' cs).
    Proof using.
      induction tvs'; simpl; auto.
      intros. eapply IHtvs'. constructor. assumption.
    Qed.

    Lemma pctxD_unwrap_tvs_ctx_subst
    : forall tvs ctx (cs : ctx_subst _) cD,
        pctxD cs = Some cD ->
        exists cD',
          pctxD (@unwrap_tvs_ctx_subst _ tvs ctx cs (fun x => x)) = Some cD' /\
          forall (us : hlist typD _) (vs : hlist typD _) (P : exprT _ _ Prop),
            cD' (fun us vs => forall vs', P us (hlist_app vs vs')) us vs <->
            cD match eq_sym (getVars_wrap_tvs tvs ctx) in _ = V
                   , eq_sym (getUVars_wrap_tvs tvs ctx) in _ = U
                     return exprT U V Prop
               with
               | eq_refl , eq_refl => P
               end
               match eq_sym (getAmbientUVars_wrap_tvs tvs ctx) in _ = V
                     return hlist _ V
               with
               | eq_refl => us
               end
               match eq_sym (getAmbientVars_wrap_tvs tvs ctx) in _ = V
                     return hlist _ V
               with
               | eq_refl => vs
               end.
    Proof using RTypeOk_typD RSymOk_func Typ2Ok_Fun.
      intros. rewrite <- unwrap_tvs_ctx_subst_unwrap_tvs_ctx_subst'.
      generalize dependent cD. revert cs. revert ctx.
      induction tvs.
      { simpl. eauto.
        eexists; split; eauto.
        intros.
        eapply pctxD_iff; eauto.
        intros.
        rewrite (@forall_hlist_nil@{Set Urefl}).
        rewrite hlist_app_nil_r.
        revert vs0.
        refine
          (match app_nil_r_trans (getVars ctx)  as Q in _ = t
                 return forall vs0 : hlist typD _,
               P us0
                 match
                   eq_sym Q in (_ = t) return (hlist typD t)
                 with
                 | eq_refl => vs0
                 end <->
               match
                 eq_sym (eq_sym Q) in (_ = V)
                 return (exprT (getUVars ctx) V Prop)
               with
               | eq_refl => P
               end us0 vs0
           with
           | eq_refl => _
           end).
        reflexivity. }
      { simpl; intros.
        specialize (@IHtvs _ _ _ H).
        forward_reason.
        generalize dependent (unwrap_tvs_ctx_subst' tvs (CAll ctx a) cs).
        intro. rewrite (ctx_subst_eta c); simpl.
        intros; forwardy.
        eexists; split; eauto.
        inv_all. subst. intros.
        specialize (H1 us vs
                       match eq_sym (app_ass_trans (getVars ctx) (a::nil) _) in _ = X
                             return exprT _ X Prop
                       with
                       | eq_refl => P
                       end).
        simpl in *.
        etransitivity; [ etransitivity; [ | eapply H1 ] | ]; clear H1.
        { eapply pctxD_iff; eauto.
          intros.
          rewrite forall_hlist_cons.
          eapply Data.Prop.forall_iff; intros.
          eapply Data.Prop.forall_iff; intros.
          rewrite hlist_app_assoc.
          clear. simpl.
          generalize dependent (app_ass_trans (getVars ctx) (a :: nil) tvs).
          simpl in *.
          generalize dependent ((getVars ctx ++ a :: nil) ++ tvs).
          intros; subst. reflexivity. }
        { clear - H.
          match goal with
          | |- _ _ ?U ?V <-> _ _ ?U' ?V' =>
            replace V with V' ; [ replace U with U' | ]
          end.
          { eapply pctxD_iff; eauto; clear.
            revert P.
            refine
              match app_ass_trans (getVars ctx) (a :: nil) tvs
                    as PF in _ = Z
                    return
                    forall (P : exprT _ Z Prop)
                           (us : hlist typD (getUVars (wrap_tvs tvs (CAll ctx a))))
                           (vs : hlist typD (getVars (wrap_tvs tvs (CAll ctx a)))),
                      match
                        eq_sym (getVars_wrap_tvs tvs (CAll ctx a)) in (_ = V)
                        return (exprT (getUVars (wrap_tvs tvs (CAll ctx a))) V Prop)
                      with
                      | eq_refl =>
                        match
                          eq_sym (getUVars_wrap_tvs tvs (CAll ctx a)) in (_ = U)
                          return (exprT U ((getVars ctx ++ a :: nil) ++ tvs) Prop)
                        with
                        | eq_refl =>
                          match
                            eq_sym PF in (_ = X)
                            return (exprT (getUVars ctx) X Prop)
                          with
                          | eq_refl => P
                          end
                        end
                      end us vs <->
                      match
                        eq_sym
                          (eq_ind_r (fun t : tenv typ => t = Z)
                                    (eq_ind_r (fun l : list typ => l = Z) eq_refl
                                              PF)
                                    (getVars_wrap_tvs tvs (CAll ctx a))) in (_ = V)
                        return (exprT (getUVars (wrap_tvs tvs (CAll ctx a))) V Prop)
                      with
                      | eq_refl =>
                        match
                          eq_sym
                            (eq_ind_r (fun t : tenv typ => t = getUVars ctx) eq_refl
                                      (getUVars_wrap_tvs tvs (CAll ctx a))) in
                          (_ = U) return (exprT U Z Prop)
                        with
                        | eq_refl => P
                        end
                      end us vs
              with
              | eq_refl => _
              end.
            generalize (getVars_wrap_tvs tvs (CAll ctx a)).
            generalize (getUVars_wrap_tvs tvs (CAll ctx a)).
            simpl.
            intros;
            repeat match goal with
               | H : @eq (tenv typ) ?X ?Y |- _ =>
                 first [ generalize dependent X | generalize dependent Y ] ; intros; subst
               | H : @eq (list typ) ?X ?Y |- _ =>
                 first [ generalize dependent X | generalize dependent Y ] ; intros; subst
               end. reflexivity. }
          { clear.
            generalize (getAmbientUVars_wrap_tvs tvs (CAll ctx a)).
            simpl in *. destruct e. reflexivity. }
          { clear.
            generalize (getAmbientVars_wrap_tvs tvs (CAll ctx a)).
            simpl. destruct e. reflexivity. } } }
    Qed.

    Lemma pctxD_wrap_tvs_ctx_subst
    : forall tvs ctx (cs : ctx_subst ctx) cD,
        pctxD cs = Some cD ->
        exists cD',
          pctxD (wrap_tvs_ctx_subst tvs cs) = Some cD' /\
          forall us vs (P : exprT _ _ Prop),
            cD (fun us vs => forall vs', P us (hlist_app vs vs')) us vs <->
            cD' match eq_sym (getVars_wrap_tvs tvs ctx) in _ = V
                                                           , eq_sym (getUVars_wrap_tvs tvs ctx) in _ = U
                      return exprT U V Prop
                with
                | eq_refl , eq_refl => P
                end
                match eq_sym (getAmbientUVars_wrap_tvs tvs ctx) in _ = V
                      return hlist _ V
                with
                | eq_refl => us
                end
                match eq_sym (getAmbientVars_wrap_tvs tvs ctx) in _ = V
                      return hlist _ V
                with
                | eq_refl => vs
                end.
    Proof using.
      induction tvs.
      { simpl. eauto.
        eexists; split; eauto.
        intros; eapply pctxD_iff; eauto.
        intros. rewrite forall_hlist_nil.
        rewrite hlist_app_nil_r. clear.
        autorewrite_with_eq_rw. reflexivity. }
      { simpl. intros.
        specialize (IHtvs (CAll ctx a) (AllSubst cs)).
        simpl in IHtvs. rewrite H in IHtvs.
        specialize (IHtvs _ eq_refl).
        destruct IHtvs as [ ? [ ? ? ] ].
        eexists; split; eauto.
        intros.
        specialize (H1 us vs
                       match eq_sym (app_ass_trans (getVars ctx) (a::nil) _) in _ = X
                             return exprT _ X Prop
                       with
                       | eq_refl => P
                       end).
        etransitivity; [ etransitivity; [ | eapply H1 ] | ]; clear H1.
        { eapply pctxD_iff; eauto.
          intros. rewrite forall_hlist_cons.
          eapply Data.Prop.forall_iff; intro.
          eapply Data.Prop.forall_iff; intro.
          rewrite hlist_app_assoc.
          clear.
          generalize dependent (eq_sym (app_ass_trans (getVars ctx) (a :: nil) tvs)).
          simpl in *. destruct e. reflexivity. }
        { match goal with
          | |- _ _ ?U ?V <-> _ _ ?U' ?V' =>
            replace V with V' ; [ replace U with U' | ]
          end.
          { eapply pctxD_iff; eauto.
            intros.
            generalize (getVars_wrap_tvs tvs (CAll ctx a)).
            generalize (getUVars_wrap_tvs tvs (CAll ctx a)).
            simpl. clear.
            intros;
            repeat match goal with
               | H : @eq (tenv typ) ?X ?Y |- _ =>
                 first [ generalize dependent X | generalize dependent Y ] ; intros; subst
               | H : @eq (list typ) ?X ?Y |- _ =>
                 first [ generalize dependent X | generalize dependent Y ] ; intros; subst
               end. simpl.
            unfold eq_ind_r, eq_ind, eq_rect. simpl.
            autorewrite_with_eq_rw.
            revert vs0. revert P.
            refine
              match app_ass_trans (getVars ctx) (a :: nil) tvs
                    as PF in _ = X
                    return
                    forall P (vs0 : hlist typD ((getVars ctx ++ a :: nil) ++ tvs)),
                      P us0
                        match
                          PF in (_ = x)
                          return (hlist typD x)
                        with
                        | eq_refl => vs0
                        end <->
                      P us0
                        match
                          match
                            eq_sym PF in (_ = y)
                            return (y = X)
                          with
                          | eq_refl => eq_refl
                          end in (_ = x) return (hlist typD x)
                        with
                        | eq_refl => vs0
                        end
              with
              | eq_refl => _
              end.
            reflexivity. }
          { clear.
            generalize (getAmbientUVars_wrap_tvs tvs (CAll ctx a)).
            simpl in *. destruct e. reflexivity. }
          { clear.
            generalize (getAmbientVars_wrap_tvs tvs (CAll ctx a)).
            simpl. destruct e. reflexivity. } } }
    Qed.

    Lemma SubstMorphism_wrap_tvs_ctx_subst
    : forall tvs' ctx cs c,
        SubstMorphism (wrap_tvs_ctx_subst tvs' cs) c ->
        SubstMorphism cs
                      (unwrap_tvs_ctx_subst tvs' c (fun x : ctx_subst ctx => x)).
    Proof using.
      intros.
      rewrite <- unwrap_tvs_ctx_subst_unwrap_tvs_ctx_subst'.
      revert H. revert ctx c cs.
      induction tvs'.
      { simpl. tauto. }
      { simpl. intros.
        eapply IHtvs' in H.
        inv_all. rewrite H. assumption. }
    Qed.

    Definition using_rewrite_db
               (hints : list (rw_lemma typ func Rbase * rtacK typ (expr typ func)))
    : RwAction _ _ _ :=
      fun e r => rw_bind (using_rewrite_db'' hints e r)
                         (fun e => rw_ret (Progress e)).

    Definition rewrite_db_sound hints : Prop :=
      Forall
        (fun
            lt : Lemma.lemma typ (expr typ func) (rw_concl typ func Rbase) *
                 CoreK.rtacK typ (expr typ func) =>
            Lemma.lemmaD (rw_conclD RbaseD) nil nil (fst lt) /\
            CoreK.rtacK_sound (snd lt)) hints.

    Theorem using_rewrite_db_sound
    : forall hints,
        rewrite_db_sound hints ->
        setoid_rewrite_spec RbaseD (using_rewrite_db hints).
    Proof using RSymOk_func RTypeOk_typD RbaseD_single_type
          Rbase_eq_ok RelDec_Correct_eq_typ Typ2Ok_Fun.
      unfold using_rewrite_db, using_rewrite_db''.
      unfold for_tactic.
      red. red. intros.
      unfold rw_bind in H0.
      forwardy. inv_all. subst.
      destruct (fun Hx =>
                    @using_rewrite_db'_sound r _ (wrap_tvs_ctx_subst tvs' cs) hints H
                                             (expr_convert (length tvs') (length (getVars ctx)) e) e1 c0 Hx
                                             (WellFormed_ctx_subst_wrap_tvs _ H1)).
      { rewrite <- H0. f_equal.
        rewrite countVars_getVars. reflexivity. }
      clear H0. subst.
      split.
      { eapply WellFormed_ctx_subst_unwrap_tvs
          with (ctx':=CTop nil nil); eauto. }
      intros.
      specialize (H3 _ _ H0); clear H0.
      destruct (pctxD cs) eqn:HpctxD_cs; trivial.
      destruct (@pctxD_wrap_tvs_ctx_subst tvs' _ _ _ HpctxD_cs) as [ ? [ ? ? ] ].
      rewrite H0 in H3.
      destruct (lambda_exprD (getUVars ctx) (tvs' ++ getVars ctx) t e) eqn:Hlambda_exprD_e; trivial.
      generalize (@exprD_conv typ _ (expr typ func) _). simpl.
      intro Hconv.
      rewrite Hconv
         with (tus':=getUVars ctx) (tvs':=getVars ctx++tvs')
              (pfu:=eq_sym (getUVars_wrap_tvs tvs' ctx)) (pfv:=eq_sym (getVars_wrap_tvs tvs' ctx))
           in H3.
      clear Hconv.
      eapply expr_convert_sound in Hlambda_exprD_e.
      destruct Hlambda_exprD_e as [ ? [ Hx ? ] ].
      rewrite Hx in *; clear Hx.
      autorewrite_with_eq_rw_in H3.
      forwardy.
      destruct (pctxD_unwrap_tvs_ctx_subst _ _ _ H3) as [ ? [ HpctxD_x1 ? ] ].
      rewrite HpctxD_x1.
      generalize (@exprD_conv typ _ (expr typ func) _). simpl.
      intro Hconv.
      rewrite Hconv
         with (pfu:=eq_sym (getUVars_wrap_tvs tvs' ctx)) (pfv:=eq_sym(getVars_wrap_tvs tvs' ctx))
           in H6.
      clear Hconv.
      progress autorewrite_with_eq_rw_in H6.
      forwardy; inv_all; subst.
      eapply expr_convert_sound in H6.
      rewrite <- countVars_getVars in *.
      destruct H6 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
      destruct H7.
      split.
      { clear H9 H8 H4.
        eapply SubstMorphism_wrap_tvs_ctx_subst; eauto. }
      { intros.
        specialize (H9 match
                        eq_sym (getAmbientUVars_wrap_tvs tvs' ctx) in (_ = V)
                        return (hlist typD V)
                      with
                      | eq_refl => us
                      end
                       match
                         eq_sym (getAmbientVars_wrap_tvs tvs' ctx) in (_ = V)
                         return (hlist typD V)
                       with
                       | eq_refl => vs
                       end).
        specialize (H8 us vs
                   (fun us0 vs0 =>
                      rD (x0 us0 vs0) (y2 us0 vs0))).
        simpl in H8.
        generalize dependent (getVars_wrap_tvs tvs' ctx).
        generalize dependent (getUVars_wrap_tvs tvs' ctx).
        generalize dependent (getAmbientUVars_wrap_tvs tvs' ctx).
        generalize dependent (getAmbientVars_wrap_tvs tvs' ctx).
        generalize (Ap_pctxD _ HpctxD_x1).
        generalize (Pure_pctxD _ HpctxD_x1).
        revert H5 H6 H7. clear.
        generalize dependent (getAmbientVars (wrap_tvs tvs' ctx)).
        generalize dependent (getAmbientUVars (wrap_tvs tvs' ctx)).
        generalize dependent (getUVars (wrap_tvs tvs' ctx)).
        generalize dependent (getVars (wrap_tvs tvs' ctx)).
        intros; subst; simpl in *.
        eapply H8 in H9; clear H8.
        revert H9. eapply H0; clear H0.
        eapply H; clear H.
        clear - H5 H6.
        intros. rewrite H5. rewrite <- H6. eauto. }
    Time Qed.

    Definition using_prewrite_db
               (hints : expr typ func -> R ->
                        list (rw_lemma typ func Rbase * rtacK typ (expr typ func)))
    : RwAction _ _ _ :=
      fun e r => rw_bind (using_prewrite_db'' hints e r)
                      (fun e => rw_ret (Progress e)).

    (** TODO(gmalecha): This is almost identical to the above theorem *)
    Theorem using_prewrite_db_sound
    : forall hints : expr typ func -> R ->
                     list (rw_lemma typ func Rbase * rtacK typ (expr typ func)),
        (forall r e,
            Forall (fun lt =>
                      (forall tus tvs t eD,
                          lambda_exprD tus tvs t e = Some eD ->
                          lemmaD (rw_conclD RbaseD) nil nil (fst lt)) /\
                      rtacK_sound (snd lt)) (hints e r)) ->
        setoid_rewrite_spec RbaseD (using_prewrite_db hints).
    Proof using RSymOk_func RTypeOk_typD RbaseD_single_type Rbase_eq_ok
          RelDec_Correct_eq_typ Typ2Ok_Fun.
      intros.
      unfold using_prewrite_db, using_prewrite_db''.
      unfold for_tactic.
      red. red. intros.
      unfold rw_bind in H0.
      forwardy. inv_all. subst.
      destruct (@using_prewrite_db_sound' hints r _ (wrap_tvs_ctx_subst tvs' cs)
                                          (expr_convert (length tvs') (length (getVars ctx)) e) e1 c0).
      { rewrite <- H0.
        unfold using_prewrite_db'.
        rewrite countVars_getVars. reflexivity. }
      { clear - H.
        intros. specialize (H r e).
        revert H.
        eapply Forall_impl. intros. destruct H.
        eauto using rtacK_sound_WellFormed_rtacK. }
      { eauto using WellFormed_ctx_subst_wrap_tvs. }
      clear H0. subst. split.
      { eapply WellFormed_ctx_subst_unwrap_tvs
          with (ctx':=CTop nil nil); eauto. }
      intros.
      specialize (fun Hx => H3 Hx _ _ H0); clear H0.
      destruct (pctxD cs) eqn:HpctxD_cs; trivial.
      destruct (@pctxD_wrap_tvs_ctx_subst tvs' _ _ _ HpctxD_cs) as [ ? [ ? ? ] ].
      rewrite H0 in H3.
      destruct (lambda_exprD (getUVars ctx) (tvs' ++ getVars ctx) t e) eqn:Hlambda_exprD_e; trivial.
      generalize (@exprD_conv typ _ (expr typ func) _). simpl.
      intro Hconv.
      rewrite Hconv
         with (tus':=getUVars ctx) (tvs':=getVars ctx++tvs')
              (pfu:=eq_sym (getUVars_wrap_tvs tvs' ctx)) (pfv:=eq_sym (getVars_wrap_tvs tvs' ctx))
           in H3.
      clear Hconv.
      eapply expr_convert_sound in Hlambda_exprD_e.
      destruct Hlambda_exprD_e as [ ? [ Hx ? ] ].
      rewrite Hx in *; clear Hx.
      autorewrite_with_eq_rw_in H3.
      match goal with
      | H : ?X -> _ |- _ =>
        match type of X with
        | Prop =>
          let H' := fresh in
          assert (H' : X) ; [ clear H | specialize (H H'); clear H' ]
        end
      end.
      { clear - H.
        intros. generalize (H r e).
        eapply Forall_impl. intros; forward_reason.
        split; eauto. }
      forwardy.
      destruct (pctxD_unwrap_tvs_ctx_subst _ _ _ H3) as [ ? [ HpctxD_x1 ? ] ].
      rewrite HpctxD_x1.
      generalize (@exprD_conv typ _ (expr typ func) _). simpl.
      intro Hconv.
      rewrite Hconv
         with (pfu:=eq_sym (getUVars_wrap_tvs tvs' ctx)) (pfv:=eq_sym(getVars_wrap_tvs tvs' ctx))
           in H6.
      clear Hconv.
      autorewrite_with_eq_rw_in H6.
      forwardy; inv_all; subst.
      eapply expr_convert_sound in H6.
      rewrite <- countVars_getVars in *.
      destruct H6 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
      destruct H7.
      split.
      { clear H9 H8 H4.
        eapply SubstMorphism_wrap_tvs_ctx_subst; eauto. }
      { intros.
        specialize (H9 match
                        eq_sym (getAmbientUVars_wrap_tvs tvs' ctx) in (_ = V)
                        return (hlist typD V)
                      with
                      | eq_refl => us
                      end
                       match
                         eq_sym (getAmbientVars_wrap_tvs tvs' ctx) in (_ = V)
                         return (hlist typD V)
                       with
                       | eq_refl => vs
                       end).
        specialize (H8 us vs
                   (fun us0 vs0 =>
                      rD (x0 us0 vs0) (y2 us0 vs0))).
        simpl in H8.
        generalize dependent (getVars_wrap_tvs tvs' ctx).
        generalize dependent (getUVars_wrap_tvs tvs' ctx).
        generalize dependent (getAmbientUVars_wrap_tvs tvs' ctx).
        generalize dependent (getAmbientVars_wrap_tvs tvs' ctx).
        generalize (Ap_pctxD _ HpctxD_x1).
        generalize (Pure_pctxD _ HpctxD_x1).
        revert H5 H6 H7. clear.
        generalize dependent (getAmbientVars (wrap_tvs tvs' ctx)).
        generalize dependent (getAmbientUVars (wrap_tvs tvs' ctx)).
        generalize dependent (getUVars (wrap_tvs tvs' ctx)).
        generalize dependent (getVars (wrap_tvs tvs' ctx)).
        intros; subst; simpl in *.
        eapply H8 in H9; clear H8.
        revert H9. eapply H0; clear H0.
        eapply H; clear H.
        clear - H5 H6.
        intros. rewrite H5. rewrite <- H6. eauto. }
    Qed.

  End reindexing.

End setoid.


Require Import floyd.proofauto.
Require Import progs.dead_if.
Require Import floyd.deadvars.

Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.

Local Open Scope logic.

Definition f_spec :=
 DECLARE _f
  WITH x : Z, y: Z, z: Z
  PRE  [_x OF tint, _y OF tint, _z OF tint]
    PROP ( ) LOCAL (temp _x (Vint (Int.repr x));
                    temp _y (Vint (Int.repr y)); temp _z (Vint (Int.repr z)))
    SEP()
  POST [ tint ] PROP() LOCAL() SEP().

Definition g_spec :=
 DECLARE _g
  WITH x : Z, y: Z, z: Z
  PRE  [_x OF tint, _y OF tint, _z OF tint]
    PROP ( ) LOCAL (temp _x (Vint (Int.repr x));
                    temp _y (Vint (Int.repr y)); temp _z (Vint (Int.repr z)))
    SEP()
  POST [ tint ] PROP() LOCAL() SEP().

Definition Vprog : varspecs := nil.

Definition Gprog : funspecs :=   ltac:(with_library prog [g_spec]).

Lemma body_f:  semax_body Vprog Gprog f_f f_spec.
Proof.
start_function.
deadvars.  (* nothing dead here *)
do 3 forward.
deadvars.  (* dead *)
forward.
deadvars.  (* nothing dead here *)
forward_if (EX i:_, EX j:_, PROP ( )
   LOCAL (temp _c (Vint (Int.repr i)); temp _b (Vint (Int.repr j)))  SEP ()).
deadvars.   (* dead *)
forward.
rewrite add_repr.
Exists 0 (x+y).
entailer!.
deadvars.  (* dead *)
forward.
forward.
Exists z x.
entailer!.
Intros i j.
forward.
Qed.

Lemma body_g:  semax_body Vprog Gprog f_g g_spec.
Proof.
start_function.
deadvars.  (* dead vars! *)
do 3 forward.
deadvars.  (* dead vars! *)
forward.
normalize.
deadvars.  (* nothing dead here *)
forward_while (EX i:_,
   PROP() LOCAL (temp _a (Vint (Int.repr (x+1))); temp _x (Vint (Int.repr x));
              temp _c (Vint (Int.repr 0)); temp _b (Vint (Int.repr i)))  SEP ()).
* Exists 1. entailer!.
* entailer!.
*
deadvars.   (* dead vars! *)
forward.
Exists x. entailer!.
*
deadvars. (* dead vars! *)
forward.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Postorder renumbering of RTL control-flow graphs. *)

Require Import Coqlib.
Require Import Maps.
Require Import Postorder.
Require Import RTL.

(** CompCert's dataflow analyses (module [Kildall]) are more precise
  and run faster when the sequence [1, 2, 3, ...]  is a postorder
  enumeration of the nodes of the control-flow graph.  This property
  can be guaranteed when generating the CFG (module [RTLgen]), but
  is, however, invalidated by further RTL optimization passes such as
  [Inlining].

  In this module, we renumber the nodes of RTL control-flow graphs
  to restore the postorder property given above.  In passing,
  we also eliminate CFG nodes that are not reachable from the entry point:
  these nodes are dead code. *)

Section RENUMBER.

Variable pnum: PTree.t positive.   (**r a postorder numbering *)

Definition renum_pc (pc: node) : node :=
  match pnum!pc with
  | Some pc' => pc'
  | None => 1%positive          (**r impossible case, never exercised *)
  end.

Definition renum_instr (i: instruction) : instruction :=
  match i with
  | Inop s => Inop (renum_pc s)
  | Iop op args res s => Iop op args res (renum_pc s)
  | Iload chunk addr args res s => Iload chunk addr args res (renum_pc s)
  | Istore chunk addr args src s => Istore chunk addr args src (renum_pc s)
  | Icall sg ros args res s => Icall sg ros args res (renum_pc s)
  | Itailcall sg ros args => i
  | Ibuiltin ef args res s => Ibuiltin ef args res (renum_pc s)
  | Icond cond args s1 s2 => Icond cond args (renum_pc s1) (renum_pc s2)
  | Ijumptable arg tbl => Ijumptable arg (List.map renum_pc tbl)
  | Ireturn or => i
  end.

Definition renum_node (c': code) (pc: node) (i: instruction) : code :=
  match pnum!pc with
  | None => c'
  | Some pc' => PTree.set pc' (renum_instr i) c'
  end.

Definition renum_cfg (c: code) : code :=
  PTree.fold renum_node c (PTree.empty instruction).

End RENUMBER.

Definition transf_function (f: function) : function :=
  let pnum := postorder (successors_map f) f.(fn_entrypoint) in
  mkfunction
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (renum_cfg pnum f.(fn_code))
    (renum_pc pnum f.(fn_entrypoint)).

Definition transf_fundef (fd: fundef) : fundef :=
  AST.transf_fundef transf_function fd.

Definition transf_program (p: program) : program :=
  AST.transform_program transf_fundef p.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Undecidability Result(s):
    Provability in Hilbert-style calculi (HSC_PRV)
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)
*)

Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.HilbertCalculi.HSC.

Require Undecidability.HilbertCalculi.Reductions.MPCPb_to_HSC_PRV.
Require Undecidability.HilbertCalculi.Reductions.MPCPb_to_HSC_AX.

Require Import Undecidability.PCP.PCP_undec.

(* Hilbert-style Axiomatization of the Post Correspondenc Problem *)
Definition ΓPCP := MPCPb_to_HSC_PRV.Argument.ΓPCP.

(* Undecidability of Provability in Hilbert-style Calculi with the Fixed Environment ΓPCP *)
Theorem HSC_PRV_undec : undecidable (HSC_PRV ΓPCP).
Proof.
  apply (undecidability_from_reducibility MPCPb_undec).
  exact MPCPb_to_HSC_PRV.reduction.
Qed.

Check HSC_PRV_undec.

(* Undecidability of Recognizing Axiomatizations of Hilbert-style Calculi *)
Theorem HSC_AX_undec : undecidable HSC_AX.
Proof.
  apply (undecidability_from_reducibility MPCPb_undec).
  exact MPCPb_to_HSC_AX.reduction.
Qed.

Check HSC_AX_undec.