Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.PartialUnfold.
Require Import Fiat.Parsers.Reflective.SyntaxEquivalence.
Require Import Fiat.Parsers.Reflective.Morphisms.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Equality.

Fixpoint related {T} : interp_TypeCode T -> normalized_of interp_TypeCode T -> Prop
  := match T return interp_TypeCode T -> normalized_of interp_TypeCode T -> Prop with
     | csimple T' => fun b e => b = interp_Term e
     | (dom --> ran)%typecode
       => fun f1 f2 => forall x1 x2, related x1 x2 -> related (f1 x1) (f2 x2)
     end.

Local Ltac concretize := cbv zeta.
Local Ltac simpler' := concretize; simpl in *; try subst; intros; auto; try subst; intros; auto;
  try congruence; try omega; try (exfalso; omega).
Local Ltac simplerGoal :=
  idtac;
  match goal with
  | [ H : False |- _ ] => destruct H
  | [ x : unit |- _ ] => destruct x
  | [ x : (_ * _)%type |- _ ] => destruct x
  | [ H : ex _ |- _ ] => destruct H
  | [ H : _ /\ _ |- _ ] => destruct H
  | [ H : _ \/ _ |- _ ] => destruct H
  | _ => progress unfold eq_rect in *
  | [ H : (_ + _)%type -> _ |- _ ]
    => pose proof (fun x => H (inl x));
       pose proof (fun x => H (inr x));
       clear H
  | [ H : forall x : ?A = clist ?A, _ |- _ ] => clear H
  | [ H : forall x : csimple ?A = csimple (clist ?A), _ |- _ ] => clear H
  | [ H : False -> _ |- _ ] => clear H
  | [ H : sigT ?P -> _ |- _ ] => specialize (fun x p => H (existT P x p))
  | [ H : sig ?P -> _ |- _ ] => specialize (fun x p => H (exist P x p))
  | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
  | [ H : forall a b c, (_ + _)%type -> _ |- _ ]
    => pose proof (fun a b c x => H a b c (inl x));
       pose proof (fun a b c x => H a b c (inr x));
       clear H
  | [ H : forall a b c, False -> _ |- _ ] => clear H
  | [ H : forall a b c, sigT _ -> _ |- _ ] => specialize (fun a b c x p => H a b c (existT _ x p))
  | [ H : forall a b c, sig _ -> _ |- _ ] => specialize (fun a b c x p => H a b c (exist _ x p))
  | [ H : forall a b c (d : ?x = a), _ |- _ ] => specialize (fun b c => H _ b c eq_refl)
  | [ H : ?P -> _ |- _ ] =>
    let H' := fresh "H'" in
    assert (H' : P); [ solve [ auto ]
                     | generalize (H H'); clear H H'; intro H ]
  | [ H : ?x = ?y |- _ ]
    => pose proof (pr2_path H);
       generalize dependent (pr1_path H);
       clear H;
       intros ??
    | [ H : forall a b, _ /\ _ -> _ |- _ ]
      => specialize (fun a b c d => H a b (conj c d))
    | [ H : forall a b (c : ?v = a), _ |- _ ]
      => specialize (fun b => H _ b eq_refl)
    | [ H : forall a (b : ?v = a), _ |- _ ]
      => specialize (H _ eq_refl)
    | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
  (*| [ H : existT ?F ?T ?X = existT _ ?T ?Y |- _ ] =>
                        generalize (inj_pair2 _ F _ X Y H); clear H*)
  | [ H : Some ?X = Some ?Y |- _ ] =>
    lazymatch X with
    | Y => clear H
    | _ => injection H; try clear H; intro
    end
  | [ H : option_map _ ?x = Some _ |- _ ]
    => destruct x eqn:?; unfold option_map at 1 in H
  | [ H : Some _ = option_map _ ?x |- _ ]
    => destruct x eqn:?; unfold option_map at 1 in H
  (*| [ H : an_arg _ _ = an_arg _ _ |- _ ]
    => apply args_for_encode in H; unfold args_for_code in H
  | [ H : noargsv = noargsv |- _ ] => clear H
  | [ H : @args_for_equiv _ _ _ (carrow _ _) _ _ |- _ ]
    => apply invert_args_for_equiv in H; cbv beta iota in H
  | [ H : @args_for_equiv _ _ _ (csimple _) _ _ |- _ ]
    => apply invert_args_for_equiv in H; cbv beta iota in H*)
  | [ |- _ /\ _ ] => split

  | [ |- context[if ?E then _ else _] ] => destruct E eqn:?
  (*| [ |- context[match ?pf with refl_equal => _ end] ] => rewrite (UIP_refl _ _ pf)*)
  | [ H : context[if ?E then _ else _] |- _ ] => destruct E eqn:?
  | [ |- (_, _) = (_, _) ] => apply f_equal2
  | [ |- cons _ _ = cons _ _ ] => apply f_equal2
  (*| [ |- an_argv _ _ = an_argv _ _ ] => apply f_equal2*)
  | _ => progress simpl
  | [ |- context[interp_Term_gen ?f ?v] ]
    => change (interp_Term_gen f v)
       with (@interp_Term_gen_step f (@interp_Term_gen f) _ v)
  | [ |- context[option_map _ ?x] ]
    => destruct x eqn:?; simpl
  (*| _ => progress unfold interp_args_for, interp_Term in **)
  end.
Local Ltac simpler := simpler'; repeat (simplerGoal; simpler').
Local Ltac simpler_args_for' :=
  idtac;
  match goal with
  | [ args : args_for _ (carrow ?A ?B) |- _ ]
    => let H := fresh in
       pose proof (invert_args_for_ex args) as H; cbv beta iota in H;
       destruct H as [? [? ?]]; subst args
  | [ args : args_for _ (csimple ?B) |- _ ]
    => let H := fresh in
       pose proof (invert_args_for_ex args) as H; cbv beta iota in H;
       subst args
  end.
Local Ltac simpler_args_for := repeat simpler_args_for'.

Lemma push_var : forall t v1 v2 t' v1' v2' G,
  vars v1' v2' = vars v1 v2
  \/ List.In (vars v1 v2) G
  -> (forall t'' v1'' v2'', List.In (vars v1'' v2'') G -> @related t'' v1'' v2'')
  -> @related t' v1' v2'
  -> @related t v1 v2.
Proof.
  simpler.
Qed.

Lemma constantOf_correct
  : forall {T} (t : Term interp_TypeCode T) v
           (H : constantOf t = Some v),
    interp_Term t = interp_constantOf v.
Proof.
  unfold interp_Term;
  intros T t; induction t;
  repeat match goal with
         | [ t : RLiteralTerm _ |- _ ] => destruct t
         | [ t : RLiteralConstructor _ |- _ ] => destruct t
         | [ H : constantOf ?bv = Some ?dv, H' : forall a b c d, constantOf b = Some d -> _ |- _ ]
           => pose proof (fun c => H' _ bv c dv H); clear H
         | _ => progress simpler_args_for
         | _ => progress simpler
         end.
Qed.

Local Ltac simpler_constantOf
  := repeat match goal with
            | [ H : constantOf ?t = Some ?v |- _ ]
              => apply (@constantOf_correct _ t v) in H
            end.

Lemma fold_left_app {A B A' B'}
      (f : A -> B -> A) (ls : list B) (init : A)
      (g : A' -> B' -> A') (ha : A -> A') (hb : B -> B')
      (H : forall x y, g (ha x) (hb y) = ha (f x y))
  : List.fold_left g (List.map hb ls) (ha init)
    = ha (List.fold_left f ls init).
Proof.
  revert init; induction ls as [|x xs IHxs]; simpl; [ reflexivity | ]; intros.
  rewrite <- IHxs, H; reflexivity.
Qed.

Lemma bool_rect_nodep_const {P x b}
  : BoolFacts.Bool.bool_rect_nodep P x x b = x.
Proof. destruct b; reflexivity. Qed.

Create HintDb partial_unfold_hints discriminated.

#[global]
Hint Rewrite <- @interp_Term_syntactify_list @interp_Term_syntactify_nat @List.map_rev : partial_unfold_hints.
#[global]
Hint Rewrite @nth'_nth List.map_nth List.map_map List.map_length List.map_id @combine_map_r @combine_map_l @first_index_default_map Bool.orb_true_r Bool.orb_true_l Bool.andb_true_l Bool.andb_true_r Bool.orb_false_r Bool.orb_false_l Bool.andb_false_l Bool.andb_false_r BoolFacts.andbr_andb BoolFacts.orbr_orb @bool_rect_nodep_const @BoolFacts.uneta_bool_rect_nodep : partial_unfold_hints.
#[global]
Hint Resolve map_ext_in fold_left_app (@constantOf_correct cbool) @first_index_default_first_index_partial : partial_unfold_hints.

Local Ltac meaning_tac_helper' :=
  idtac;
  match goal with
  | [ |- ?x = ?y ] => reflexivity
  | [ H : forall a b (c : a = _), _ |- _ ] => specialize (fun b => H _ b eq_refl)
  | [ H : forall a b c (d : b = _), _ |- _ ] => specialize (fun a c => H a _ c eq_refl)
  | [ H : forall x y, _ = _ |- _ ] => setoid_rewrite <- H
  | [ |- context[Common.apply_n ?n ?f ?x] ]
    => clear;
       let IH := fresh "IH" in
       generalize x; induction n as [|? IH]; simpl;
       [ reflexivity
       | intro; rewrite <- IH; unfold interp_Term; simpl;
         first [ reflexivity
               | omega ] ]
  | [ |- context[Operations.List.list_caset_nodep _ _ ?ls] ]
    => is_var ls; destruct ls
  | [ |- Operations.List.list_caset_nodep _ _ ?ls = Operations.List.list_caset_nodep _ _ ?ls ]
    => destruct ls
  | [ H : ?x = _ |- context[?x] ] => rewrite H
  | [ |- context[Reflective.ritem_rect_nodep _ _ ?x] ]
    => destruct x eqn:?; simpl
  | [ H : forall x, _ = _ |- _ ] => rewrite <- H; reflexivity
  | [ H : forall x, _ = _ |- _ ] => setoid_rewrite <- H; reflexivity
  | [ |- context[match ?x with Some _ => _ | None => _ end] ]
    => destruct x eqn:?
  end.
Local Ltac meaning_tac_helper := repeat meaning_tac_helper'.

Local Ltac meaning_tac :=
  repeat first [ progress autorewrite with partial_unfold_hints
               | progress eauto with partial_unfold_hints
               | progress rewrite_strat (topdown (hints partial_unfold_hints))
               | progress meaning_tac_helper
               | progress simpl_interp_Term_in_all ].

Local Hint Extern 1 (@related ?T ?X (reflect (RVar ?Y))) =>
change (@related T (interp_Term (RVar X)) (reflect (RVar Y))).
Local Hint Extern 1 (@related _ (interp_Term_gen ?iRLT ?A ?X1) _) =>
  change (interp_Term_gen iRLT A X1)
  with (interp_Term_gen iRLT (RApp A (RVar X1))).
Lemma reify_and_reflect_correct : forall t,
    (forall v r,
        @related t v r
        -> Proper_relation_for _ v (interp_Term (reify _ r)))
    /\ (forall a a',
           @Proper_relation_for t (interp_Term a) (interp_Term a')
           -> @related t (interp_Term a) (reflect a')).
Proof.
  unfold interp_Term;
  induction t; simpler; unfold respectful; eauto.
Qed.

Lemma reify_correct : forall t v r,
  @related t v r
  -> Proper_relation_for _ v (interp_Term (reify _ r)).
Proof.
  generalize reify_and_reflect_correct; firstorder.
Qed.

Lemma args_for_related_related_map {T v1 v2} (f := @meaning _)
  : (args_for_related
       (T := T)
       (fun T (m : Term interp_TypeCode T) (n : Term (normalized_of interp_TypeCode) T)
        => related (interp_Term m) (f T n))
       v1 v2)
    -> (args_for_related (fun T => Proper_relation_for T)
                          (map_args_for (@interp_Term) v1)
                          (map_args_for (@interp_Term) (unmeanings (meanings f v2)))).
Proof.
  subst f; revert v2.
  induction v1; intro;
    pose proof (invert_args_for_ex v2) as H'; simpl in *;
      [ destruct H' as [? [? ?]] | subst; split; reflexivity ];
      subst; simpl in *.
  intros [H0 H1]; split; try assumption;
    [ | apply IHv1; assumption ]; clear IHv1.
  apply reify_and_reflect_correct; assumption.
Qed.

Lemma interp_apply_meaning_helper
      T f f' (Hf : @related T f f')
      args args'
      (Hargs : args_for_related (fun T' m n => related (interp_Term m) (meaning n)) args args')
  : apply_args_for f (map_args_for (fun _ t => interp_Term t) args)
    = interp_Term (apply_meaning_helper (meanings (@meaning interp_TypeCode) args') f').
Proof.
  apply args_for_related_noind_ind in Hargs.
  revert f f' Hf.
  induction Hargs; [ | solve [ simpl; trivial ] ].
  apply args_for_related_noind_ind in Hargs.
  simpl in *.
  eauto with nocore.
Qed.

Local Ltac simpler_meaning :=
  repeat match goal with
         | _ => progress simpler_constantOf
         | _ => progress simpler_args_for
         | _ => progress simpl_interp_Term_in_all
         | _ => progress simpler
         | _ => progress simpl in *
         | [ H : ?x = _ |- context[?x] ] => rewrite H
         | [ H : context[match constantOf ?x with _ => _ end] |- _ ]
           => destruct (constantOf x) eqn:?
         | [ H : match ?T with cbool => _ | _ => _ end _ = Some _ |- _ ]
           => is_var T; destruct T
         end.

Lemma list_rect_nodep_meaning_correct {A : SimpleTypeCode} {P} f f' n n'
      (Hn : @related P n n')
      (Hf : @related (A --> clist A --> P --> P) f f')
      (ls : list (Term interp_TypeCode A))
  : related (Operations.List.list_rect_nodep n f (List.map (@interp_Term _) ls))
            (Operations.List.list_rect_nodep n' (fun x xs => f' x (Syntactify.syntactify_list xs)) ls).
Proof.
  induction ls; simpl in *; [ assumption | ].
  apply Hf; eauto using eq_refl, @interp_Term_syntactify_list with nocore.
Qed.

#[global]
Hint Resolve @list_rect_nodep_meaning_correct : partial_unfold_hints.

Lemma specific_meaning_correct
      t r val v1 v2
      (Hrel : args_for_related
                (fun T' m n => @related T' (interp_Term m) (meaning n)) v1 v2)
      (Heq : specific_meaning r (meanings (@meaning interp_TypeCode) v2) = Some val)
  : interp_Term (@RLiteralApp _ t r v1) = interp_Term val.
Proof.
  destruct r; simpl in Heq;
    unfold specific_meaning_apply1, specific_meaning_apply2 in *;
    try solve [ simpler_meaning; meaning_tac ].
  { simpler_meaning; meaning_tac.
    apply interp_apply_meaning_helper; simpl; try assumption; [].
    apply list_rect_nodep_meaning_correct; simpl; eauto with nocore.
    simpler_meaning; meaning_tac. }
  { simpler_meaning; meaning_tac.
    rewrite Plus.plus_comm; meaning_tac. }
Qed.

Local Hint Resolve push_var.
Lemma meaning_correct
  : forall G t e1 e2,
    Term_equiv G e1 e2
    -> (forall t' v1 v2, List.In (vars v1 v2) G
                         -> @related t' v1 v2)
    -> @related t (interp_Term e1) (meaning e2).
Proof.
  unfold interp_Term;
    induction 1 (*using Term_equiv_ind_in*); try solve [ simpler; eauto ].
  { simpler.
    repeat match goal with
           | [ H : args_for_related_ind _ _ _ |- _ ]
             => apply args_for_related_noind_ind in H
           | [ H : args_for_related (fun x y z => ?P -> _) _ _ |- _ ]
             => setoid_rewrite <- args_for_related_impl in H
           | _ => progress simpl_interp_Term_in_all
           | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
           | [ f : RLiteralTerm _ |- _ ] => destruct f
           | [ |- apply_args_for _ _ = apply_args_for _ _ ]
             => apply apply_args_for_Proper;
                  [ apply RLiteralTerm_Proper | apply args_for_related_related_map; assumption ]
           | [ |- context[specific_meaning ?r ?x] ]
             => destruct (specific_meaning r x) eqn:?
           end.
    eapply specific_meaning_correct; eassumption. }
Qed.

Lemma nil_context : forall t v1 v2,
  List.In (vars v1 v2) nil
  -> @related t v1 v2.
Proof.
  simpl; tauto.
Qed.

Local Hint Resolve nil_context meaning_correct reify_correct.
Theorem polynormalize_correct : forall t (E : polyTerm t),
    Term_equiv nil (E interp_TypeCode) (E (normalized_of interp_TypeCode))
    -> Proper_relation_for _ (interp_Term (E _)) (interp_Term (polynormalize E _)).
Proof.
  unfold interp_Term, polynormalize, normalize; eauto.
Qed.


(** This file contains record definitions for
 ** type, function and predicate environments.
 **)
Require Import Expr SepExpr.
Require Import Env.

Set Implicit Arguments.
Set Strict Implicit.

Module Type CoreEnv.
  Parameter core : Repr type.
  Parameter pc : tvar.
  Parameter st : tvar.
End CoreEnv.

Module Type Package.
  Declare Module SEP : SepExpr.
  Declare Module CE : CoreEnv.

  Record TypeEnv : Type :=
  { Types : Repr type
  ; Funcs : forall ts, Repr (signature (repr CE.core (repr Types ts)))
  ; Preds : forall ts,
    Repr (SEP.predicate (repr CE.core (repr Types ts)) CE.pc CE.st)
  }.

  Section Apps.
    Variable TE : TypeEnv.

    Definition applyTypes (ls : list type) : list type :=
      repr CE.core (repr (Types TE) ls).
    Definition applyFuncs ts (ls : functions (applyTypes ts)) : functions (applyTypes ts) :=
      repr (Funcs TE ts) ls.
    Definition applyPreds ts (ls : SEP.predicates (applyTypes ts) CE.pc CE.st) : SEP.predicates (applyTypes ts) CE.pc CE.st :=
      repr (Preds TE ts) ls.
  End Apps.

  (** These are reducible by [simpl] **)
  Definition applyTypes_red TE (ls : list type) : list type :=
    match TE with
      | {| Types := ts |} =>
        repr CE.core (repr ts ls)
    end.
  Definition applyFuncs_red TE ts : functions (applyTypes TE ts) -> functions (applyTypes TE ts) :=
    match TE with
      | {| Types := ts' ; Funcs := fs |} => fun ls =>
        repr (fs ts) ls
    end.
  Definition applyPreds_red TE ts : SEP.predicates (applyTypes TE ts) CE.pc CE.st -> SEP.predicates (applyTypes TE ts) CE.pc CE.st :=
    match TE with
      | {| Types := ts' ; Preds := ps |} => fun ls =>
        repr (ps ts) ls
    end.

  Ltac glue_env l r ret :=
    let res := constr:(
      let types := Env.repr_combine (Types l) (Types r) in
      {| Types := types
       ; Funcs := fun ts => Env.repr_combine (Funcs l (Env.repr types ts)) (Funcs r (Env.repr types ts))
       ; Preds := fun ts => Env.repr_combine (Preds l (Env.repr types ts)) (Preds r (Env.repr types ts))
       |})
    in
    ret res.

End Package.

Module Type AlgoTypes (SEP : SepExpr) (CE : CoreEnv).
  Parameter AlgoImpl  : list type -> Type.
  Parameter AlgoProof : forall ts : list type,
    functions (repr CE.core ts) ->
    SEP.predicates (repr CE.core ts) CE.pc CE.st ->
    AlgoImpl ts -> Type.
End AlgoTypes.

Module Make (SEP' : SepExpr) (CE' : CoreEnv) <: Package with Module SEP := SEP' with Module CE := CE'.
  Module SEP := SEP'.
  Module CE := CE'.

  Section TypeEnv.
    Record TypeEnv : Type :=
    { Types : Repr type
    ; Funcs : forall ts, Repr (signature (repr CE.core (repr Types ts)))
    ; Preds : forall ts, Repr (SEP.predicate (repr CE.core (repr Types ts)) CE.pc CE.st)
    }.

    Variable TE : TypeEnv.

    Definition applyTypes (ls : list type) : list type :=
      repr CE.core (repr (Types TE) ls).
    Definition applyFuncs ts (ls : functions (applyTypes ts)) : functions (applyTypes ts) :=
      repr (Funcs TE ts) ls.
    Definition applyPreds ts (ls : SEP.predicates (applyTypes ts) CE.pc CE.st) : SEP.predicates (applyTypes ts) CE.pc CE.st :=
      repr (Preds TE ts) ls.

  End TypeEnv.

  Definition applyTypes_red TE (ls : list type) : list type :=
    match TE with
      | {| Types := ts |} =>
        repr CE.core (repr ts ls)
    end.
  Definition applyFuncs_red TE ts : functions (applyTypes TE ts) -> functions (applyTypes TE ts) :=
    match TE with
      | {| Types := ts' ; Funcs := fs |} => fun ls =>
        repr (fs ts) ls
    end.
  Definition applyPreds_red TE ts : SEP.predicates (applyTypes TE ts) CE.pc CE.st -> SEP.predicates (applyTypes TE ts) CE.pc CE.st :=
    match TE with
      | {| Types := ts' ; Preds := ps |} => fun ls =>
        repr (ps ts) ls
    end.

End Make.

Module AlgoPack (P : Package) (A : AlgoTypes P.SEP P.CE).

  Record TypedPackage : Type :=
  { Env   : P.TypeEnv
  ; Algos : forall ts, A.AlgoImpl ts
  ; Algos_correct : forall ts (fs : functions (P.applyTypes Env ts)) ps,
    @A.AlgoProof (repr (P.Types Env) ts) (P.applyFuncs Env ts fs) (P.applyPreds Env ts ps) (Algos _)
  }.

  (** given to [TypedPackage]s, combines them and passes the combined [TypedPackage]
   ** to [k].
   ** This tactic will fail if any of the environments are not compatible.
   **)
  Ltac glue_pack composite composite_correct l r ret :=
    P.glue_env (Env l) (Env r) ltac:(fun nenv' =>
      let res := constr:(
        let nenv := nenv' in
        let types := P.Types nenv in
        {| Env   := nenv
         ; Algos := fun ts => composite (Algos l (P.applyTypes nenv ts)) (Algos r (Env.repr types ts))
         ; Algos_correct := fun ts fs ps =>
           composite_correct
             (Algos_correct l (P.applyTypes nenv ts) (P.applyFuncs nenv fs) (P.applyPreds nenv ps))
             (Algos_correct r (P.applyTypes nenv ts) (P.applyFuncs nenv fs) (P.applyPreds nenv ps))
         |})
      in
      ret res).
(*
(**
      let algosL := constr:(fun ts => Algos l (applyTypes nenvEnv.repr ntypesV ts)) in
      let algosR := constr:(fun ts => Algos r (Env.repr ntypesV ts)) in
      let algosCL :=
        constr:(fun ts fs ps =>
          Algos_correct l (Env.repr ntypesV ts)
          (Env.repr (nfuncsV ts) fs)
          (Env.repr (npredsV ts) ps)) in
      let algosCR :=
        constr:(fun ts fs ps =>
          Algos_correct r (Env.repr ntypesV ts)
          (Env.repr (nfuncsV ts) fs)
          (Env.repr (npredsV ts) ps)) in
      let pf := constr:(fun ts fs ps => AllAlgos_correct_composite (algosCL ts fs ps) (algosCR ts fs ps)) in
      opaque pf ltac:(fun pf =>
      let res :=
        constr:{|
          Types := ntypesV;
          Funcs := nfuncsV;
          Preds := npredsV;
          Algos := fun ts => AllAlgos_composite (algosL ts) (algosR ts);
          Algos_correct := pf
        |} in
        ret res)).
**)

  Ltac refine_glue_pack l r :=
    let reduce_repr e := e in
    let opaque v k := k v in
    match eval hnf in l with
      | @Build_TypedPackage ?CT ?PC ?ST ?SAT ?READ ?WRITE ?tl ?fl ?pl ?al ?acl =>
        match eval hnf in r with
        | @Build_TypedPackage _ _ _ _ _ _ ?tr ?fr ?pr ?ar ?acr =>
          refine (
              let types := repr_combine tl tr in
              let funcs := fun ts => repr_combine (fl (repr types ts)) (fr (repr types ts)) in
              let preds := fun ts => repr_combine (pl (repr types ts)) (pr (repr types ts)) in
              @Build_TypedPackage CT PC ST SAT READ WRITE
                types funcs preds
                (fun ts => AllAlgos_composite (al (repr types ts)) (ar (repr types ts)))
                _
               );
          (subst; abstract exact (fun ts fs ps => AllAlgos_correct_composite
                  (acl (repr (repr_combine tl tr) ts)
                       (repr (repr_combine (fl (repr (repr_combine tl tr) ts)) (fr (repr (repr_combine tl tr) ts))) fs)
                       (repr (repr_combine (pl (repr (repr_combine tl tr) ts)) (pr (repr (repr_combine tl tr) ts))) ps))
                  (acr (repr (repr_combine tl tr) ts)
                       (repr (repr_combine (fl (repr (repr_combine tl tr) ts)) (fr (repr (repr_combine tl tr) ts))) fs)
                       (repr (repr_combine (pl (repr (repr_combine tl tr) ts)) (pr (repr (repr_combine tl tr) ts))) ps))))
      end
  end.

(*
Ltac hlist_from_tuple tpl acc :=
  match tpl with
    | tt => acc
    | (?L, ?R) =>
      let acc := hlist_from_tuple R acc in
      hlist_from_tuple L acc
    | _ => constr:(@HCons _ _ _ _ tpl acc)
  end.
*)

(** given a tuple or list of [TypedPackage]s, this tactic combines them all and calls [k] with
 ** the result.
 **)
Ltac glue_packs packs k :=
  match type of packs with
    | TypedPackage _ _ _ _ _ _ => k packs
    | _ =>
      match packs with
        | tt => k BedrockPackage.bedrock_package
        | nil => k BedrockPackage.bedrock_package
        | ?L :: ?R =>
          glue_packs R ltac:(fun R => glue_pack L)
        | (?L, ?R) =>
          glue_packs L ltac:(fun L =>
          glue_packs R ltac:(fun R =>
            glue_pack L R k))
      end
  end.

(** TODO: is there a way to make this more efficient? **)
Ltac opaque_pack pack :=
  match eval hnf in pack with
    | @Build_TypedPackage ?CT ?PC ?ST ?SAT ?READ ?WRITE ?tl ?fl ?pl ?al ?acl =>
      refine ({|
        Types := tl ;
        Funcs := fl ;
        Preds := pl ;
        Algos := al ;
        Algos_correct := _
      |});
      abstract (exact acl)
  end.
*)

End AlgoPack.


Local Unset Elimination Schemes.

Inductive P : Type := a | b.

Inductive W : P -> Type :=.

Fail Axiom b : W a.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect ssrbool.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICTyping PCUICCumulativity
     PCUICReduction PCUICWeakeningConv PCUICWeakeningTyp PCUICEquality PCUICUnivSubstitutionConv
     PCUICSigmaCalculus PCUICContextReduction
     PCUICParallelReduction PCUICParallelReductionConfluence PCUICClosedConv PCUICClosedTyp
     PCUICRedTypeIrrelevance PCUICOnFreeVars PCUICConfluence PCUICSubstitution.

Require Import CRelationClasses CMorphisms.
Require Import Equations.Prop.DepElim.
Require Import Equations.Type.Relation Equations.Type.Relation_Properties.
From Equations Require Import Equations.

(* We show that conversion/cumulativity starting from well-typed terms is transitive.
  We first use typing to decorate the reductions/comparisons with invariants
  showing that all the considered contexts/terms are well-scoped. In a second step
  we use confluence of one-step reduction on well-scoped terms [ws_red_confluence], which also
  commutes with alpha,universe-equivalence of contexts and terms [red1_eq_context_upto_l].
  We can now derive transitivity of the conversion relation on *well-scoped*
  terms. To deal with the closedness side condition we put them in the definition
  of conversion/cumulativity: as terms need to move between contexts, and
  we sometimes need to consider conversion in open contexts, we work with
  them in an unpacked style.
  This allows to state theorems about conversion/cumulativity of general terms
  and contexts without wrapping/unwrapping them constantly into subsets.
*)

Reserved Notation " Σ ;;; Γ ⊢ t ≤[ pb ] u" (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  ≤[ pb ]  u").

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Inductive ws_cumul_pb {cf} (pb : conv_pb) (Σ : global_env_ext) (Γ : context) : term -> term -> Type :=
| ws_cumul_pb_compare (t u : term) :
  is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u ->
  compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ ⊢ t ≤[pb] u
| ws_cumul_pb_red_l (t u v : term) :
  is_closed_context Γ ->
  is_open_term Γ t -> is_open_term Γ u -> is_open_term Γ v ->
  red1 Σ Γ t v -> Σ ;;; Γ ⊢ v ≤[pb] u -> Σ ;;; Γ ⊢ t ≤[pb] u
| ws_cumul_pb_red_r (t u v : term) :
  is_closed_context Γ ->
  is_open_term Γ t -> is_open_term Γ u -> is_open_term Γ v ->
  Σ ;;; Γ ⊢ t ≤[pb] v -> red1 Σ Γ u v -> Σ ;;; Γ ⊢ t ≤[pb] u
where " Σ ;;; Γ ⊢ t ≤[ pb ] u " := (ws_cumul_pb pb Σ Γ t u) : type_scope.
Derive Signature NoConfusion for ws_cumul_pb.

Notation " Σ ;;; Γ ⊢ t ≤ u " := (ws_cumul_pb Cumul Σ Γ t u) (at level 50, Γ, t, u at next level,
    format "Σ  ;;;  Γ  ⊢  t  ≤  u") : type_scope.

Notation " Σ ;;; Γ ⊢ t = u " := (ws_cumul_pb Conv Σ Γ t u) (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  =  u") : type_scope.

Lemma ws_cumul_pb_refl' {pb} {cf} {Σ} (Γ : closed_context) (t : open_term Γ) : ws_cumul_pb pb Σ Γ t t.
Proof.
  constructor; eauto with fvs. reflexivity.
Qed.

#[global]
Instance ws_cumul_pb_sym {cf Σ Γ} : Symmetric (ws_cumul_pb Conv Σ Γ).
Proof.
  move=> x y; elim.
  - move=> t u clΓ clt clu eq.
    constructor 1; eauto with fvs.
    cbn in *; now symmetry.
  - move=> t u v clΓ clt clu clv r c c'.
    econstructor 3; tea.
  - move=> t u v clΓ clt clu clv r c c'.
    econstructor 2; tea.
Qed.

Lemma red1_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y :
  red1 Σ Γ x y ->
  is_closed_context Γ ->
  is_open_term Γ x ->
  is_open_term Γ y.
Proof.
  intros. eapply red1_on_free_vars; eauto with fvs.
Qed.
#[global] Hint Immediate red1_is_open_term : fvs.

Lemma red_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y :
  red Σ Γ x y ->
  is_closed_context Γ ->
  is_open_term Γ x ->
  is_open_term Γ y.
Proof.
  intros. eapply red_on_free_vars; eauto with fvs.
Qed.
#[global] Hint Immediate red_is_open_term : fvs.

Lemma ws_cumul_pb_is_open_term {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y ->
  [&& is_closed_context Γ, is_open_term Γ x & is_open_term Γ y].
Proof.
  now induction 1; rewrite ?i ?i0 ?i1 ?i2.
Qed.

Lemma ws_cumul_pb_is_closed_context {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y -> is_closed_context Γ.
Proof.
  now induction 1; rewrite ?i ?i0 ?i1 ?i2.
Qed.

Lemma ws_cumul_pb_is_open_term_left {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ}
  {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y -> is_open_term Γ x.
Proof.
  now induction 1; rewrite ?i ?i0 ?i1 ?i2.
Qed.

Lemma ws_cumul_pb_is_open_term_right {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y -> is_open_term Γ y.
Proof.
  now induction 1; rewrite ?i ?i0 ?i1.
Qed.

#[global] Hint Resolve ws_cumul_pb_is_closed_context ws_cumul_pb_is_open_term_left ws_cumul_pb_is_open_term_right : fvs.

Lemma ws_cumul_pb_alt `{cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t u :
  Σ ;;; Γ ⊢ t ≤[pb] u <~>
  ∑ v v',
    [× is_closed_context Γ, is_open_term Γ t, is_open_term Γ u,
      red Σ Γ t v, red Σ Γ u v' & compare_term pb Σ (global_ext_constraints Σ) v v'].
Proof.
  split.
  - induction 1.
    + exists t, u. intuition auto.
    + destruct IHX as (v' & v'' & [-> _ -> redv redv' leqv]).
      rewrite i0 /=.
      exists v', v''. split; auto. now eapply red_step.
    + destruct IHX as (v' & v'' & [-> -> cl redv redv' leqv ]).
      exists v', v''. split; auto. now eapply red_step.
  - intros (v' & v'' & [clΓ clt clu redv redv' leqv]).
    apply clos_rt_rt1n in redv.
    apply clos_rt_rt1n in redv'.
    induction redv in u, v'', redv', leqv, clt, clu |- *.
    * induction redv' in x, leqv, clt, clu |- *.
    ** constructor; auto.
    ** econstructor 3; tas. 2:eapply IHredv'. all:tea; eauto with fvs.
    * econstructor 2; revgoals. eapply IHredv; cbn; eauto with fvs. all:eauto with fvs.
Qed.

Lemma ws_cumul_pb_forget {cf:checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {x y} :
  ws_cumul_pb pb Σ Γ x y -> Σ ;;; Γ |- x <=[pb] y.
Proof.
  induction 1.
  - constructor; auto.
  - econstructor 2; eauto.
  - econstructor 3; eauto.
Qed.

Lemma ws_cumul_pb_forget_cumul {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {x y} :
  ws_cumul_pb Cumul Σ Γ x y -> Σ ;;; Γ |- x <=[Cumul] y.
Proof. apply (ws_cumul_pb_forget (pb:=Cumul)). Qed.

Lemma ws_cumul_pb_forget_conv {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {x y} :
  ws_cumul_pb Conv Σ Γ x y -> Σ ;;; Γ |- x <=[Conv] y.
Proof. apply (ws_cumul_pb_forget (pb:=Conv)). Qed.
#[global] Hint Resolve ws_cumul_pb_forget_cumul ws_cumul_pb_forget_conv : pcuic.

#[global]
Instance ws_cumul_pb_trans {cf:checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} :
  Transitive (ws_cumul_pb pb Σ Γ).
Proof.
  move=> t u v /ws_cumul_pb_alt [t' [u' [clΓ clt clu tt' uu' eq]]]
    /ws_cumul_pb_alt[u'' [v' [_ clu' clv uu'' vv' eq']]].
  eapply ws_cumul_pb_alt.
  destruct (red_confluence (Γ := exist Γ clΓ) (t:=exist u clu) uu' uu'') as [u'nf [ul ur]].
  destruct pb; cbn in *.
  { eapply red_eq_term_upto_univ_r in ul as [tnf [redtnf ?]]; tea; try tc.
    eapply red_eq_term_upto_univ_l in ur as [unf [redunf ?]]; tea; try tc.
    exists tnf, unf.
    split; auto; eauto with fvs.
    - now transitivity t'.
    - now transitivity v'.
    - now transitivity u'nf. }
  { eapply red_eq_term_upto_univ_r in ul as [tnf [redtnf ?]]; tea; try tc.
    eapply red_eq_term_upto_univ_l in ur as [unf [redunf ?]]; tea; try tc.
    exists tnf, unf.
    split; eauto with fvs.
    - now transitivity t'.
    - now transitivity v'.
    - now transitivity u'nf. }
Qed.

Arguments wt_cumul_pb_dom {cf c Σ Γ T U}.
Arguments wt_cumul_pb_codom {cf c Σ Γ T U}.
Arguments wt_cumul_pb_eq {cf c Σ Γ T U}.

Section EqualityLemmas.
  Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Lemma isType_open {Γ T} : isType Σ Γ T -> on_free_vars (shiftnP #|Γ| xpred0) T.
  Proof using wfΣ.
    move/isType_closedPT. now rewrite closedP_shiftnP.
  Qed.

  Lemma into_ws_cumul_pb {pb} {Γ : context} {T U} :
    Σ;;; Γ |- T <=[pb] U ->
    is_closed_context Γ -> is_open_term Γ T ->
    is_open_term Γ U ->
    Σ ;;; Γ ⊢ T ≤[pb] U.
  Proof using wfΣ.
    induction 1.
    - constructor; auto.
    - intros. econstructor 2 with v; cbn; eauto with fvs.
    - econstructor 3 with v; cbn; eauto with fvs.
  Qed.

  Lemma isType_ws_cumul_pb_refl {pb} Γ T : isType Σ Γ T -> Σ ;;; Γ ⊢ T ≤[pb] T.
  Proof using wfΣ.
    intros H.
    pose proof (isType_wf_local H).
    eapply (ws_cumul_pb_refl' (exist Γ (wf_local_closed_context X)) (exist T (isType_open H))).
  Qed.

  (** From well-typed to simply well-scoped equality. *)
  Lemma wt_cumul_pb_ws_cumul_pb {pb} {Γ : context} {T U} :
    wt_cumul_pb pb Σ Γ T U ->
    ws_cumul_pb pb Σ Γ T U.
  Proof using wfΣ.
    move=> [] dom codom equiv; cbn.
    generalize (wf_local_closed_context (isType_wf_local dom)).
    generalize (isType_open dom) (isType_open codom). clear -wfΣ equiv.
    intros. apply into_ws_cumul_pb => //.
  Qed.

  Lemma wt_cumul_pb_trans pb Γ :
    Transitive (wt_cumul_pb pb Σ Γ).
  Proof using wfΣ.
    intros x y z cum cum'.
    have wscum := (wt_cumul_pb_ws_cumul_pb cum).
    have wscum' := (wt_cumul_pb_ws_cumul_pb cum').
    generalize (transitivity wscum wscum'). clear wscum wscum'.
    destruct cum, cum'; split=> //.
    apply ws_cumul_pb_forget in X. now cbn in X.
  Qed.

  Global Instance conv_trans Γ : Transitive (wt_conv Σ Γ).
  Proof using wfΣ. apply wt_cumul_pb_trans. Qed.

  Global Instance cumul_trans Γ : Transitive (wt_cumul Σ Γ).
  Proof using wfΣ. apply wt_cumul_pb_trans. Qed.

End EqualityLemmas.

Set Warnings "-uniform-inheritance".
Coercion wt_cumul_pb_ws_cumul_pb : wt_cumul_pb >-> ws_cumul_pb.
Set Warnings "uniform-inheritance".

#[global] Hint Immediate isType_ws_cumul_pb_refl : pcuic.

Record closed_relation {R : context -> term -> term -> Type} {Γ T U} :=
  { clrel_ctx : is_closed_context Γ;
    clrel_src : is_open_term Γ T;
    clrel_rel : R Γ T U }.
Arguments closed_relation : clear implicits.

#[global] Hint Immediate clrel_ctx clrel_src : fvs.

Definition closed_red1 Σ := (closed_relation (red1 Σ)).
Definition closed_red1_red1 {Σ Γ T U} (r : closed_red1 Σ Γ T U) := clrel_rel r.
#[global] Hint Resolve closed_red1_red1 : fvs.
Coercion closed_red1_red1 : closed_red1 >-> red1.

Lemma closed_red1_open_right {cf} {Σ Γ T U} {wfΣ : wf Σ} (r : closed_red1 Σ Γ T U) : is_open_term Γ U.
Proof.
  destruct r. eauto with fvs.
Qed.

Definition closed_red Σ := (closed_relation (red Σ)).
Definition closed_red_red {Σ Γ T U} (r : closed_red Σ Γ T U) := clrel_rel r.
#[global] Hint Immediate closed_red_red : fvs.
Coercion closed_red_red : closed_red >-> red.

Lemma closed_red_open_right {cf} {Σ Γ T U} {wfΣ : wf Σ} (r : closed_red Σ Γ T U) : is_open_term Γ U.
Proof.
  destruct r. eauto with fvs.
Qed.

From Equations.Type Require Import Relation_Properties.

(* \rightsquigarrow *)
Notation "Σ ;;; Γ ⊢ t ⇝ u" := (closed_red Σ Γ t u) (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  ⇝  u").

Lemma closed_red1_red {Σ Γ t t'} : closed_red1 Σ Γ t t' -> Σ ;;; Γ ⊢ t ⇝ t'.
Proof.
  intros []. split => //.
  now eapply red1_red.
Qed.

Lemma ws_cumul_pb_alt_closed {cf} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t u :
  Σ ;;; Γ ⊢ t ≤[pb] u <~>
  ∑ v v',
    [× closed_red Σ Γ t v, closed_red Σ Γ u v' &
       compare_term pb Σ (global_ext_constraints Σ) v v'].
Proof.
  etransitivity. apply ws_cumul_pb_alt.
  split; intros (v & v' & cl); exists v, v'; intuition.
Qed.

Lemma biimpl_introT {T} {U} : Logic.BiImpl T U -> T -> U.
Proof. intros [] => //. Qed.

Hint View for move/ biimpl_introT|2.

Lemma ws_cumul_pb_refl {cf} {Σ} {pb Γ t} : is_closed_context Γ -> is_open_term Γ t -> Σ ;;; Γ ⊢ t ≤[pb] t.
Proof.
  move=> clΓ clt.
  constructor; cbn; eauto with fvs. reflexivity.
Qed.
#[global] Hint Immediate ws_cumul_pb_refl : pcuic.

Section RedConv.
  Context {cf} {Σ} {wfΣ : wf Σ}.

  Lemma red_conv {pb Γ t u} : Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ t ≤[pb] u.
  Proof using wfΣ.
    move=> [clΓ clT /clos_rt_rt1n_iff r].
    induction r.
    - now apply ws_cumul_pb_refl.
    - econstructor 2. 5:tea.
      all:eauto with fvs.
  Qed.

  Lemma red_ws_cumul_pb_left {pb Γ} {t u v} :
    Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ u ≤[pb] v -> Σ ;;; Γ ⊢ t ≤[pb] v.
  Proof using wfΣ.
    move=> [clΓ clT /clos_rt_rt1n_iff r].
    induction r; auto.
    econstructor 2. 5:tea. all:eauto with fvs.
  Qed.

  Lemma red_ws_cumul_pb_right {pb Γ t u v} :
    Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ v ≤[pb] u -> Σ ;;; Γ ⊢ v ≤[pb] t.
  Proof using wfΣ.
    move=> [clΓ clT /clos_rt_rt1n_iff r].
    induction r; auto.
    econstructor 3. 5:eapply IHr. all:eauto with fvs.
  Qed.

  (* synonym of red_conv *)
  Lemma red_ws_cumul_pb {pb Γ t u} :
    Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ t ≤[pb] u.
  Proof using wfΣ.
    move=> r; eapply red_ws_cumul_pb_left; tea.
    eapply ws_cumul_pb_refl; eauto with fvs.
  Qed.

  Lemma red_ws_cumul_pb_inv {pb Γ t u} :
    Σ ;;; Γ ⊢ t ⇝ u ->
    Σ ;;; Γ ⊢ u ≤[pb] t.
  Proof using wfΣ.
    move=> r; eapply red_ws_cumul_pb_right; tea.
    eapply ws_cumul_pb_refl; eauto with fvs.
  Qed.
End RedConv.

#[global] Hint Resolve red_conv red_ws_cumul_pb red_ws_cumul_pb_inv : pcuic.

Set SimplIsCbn.

Definition conv_cum {cf:checker_flags} pb Σ Γ T T' :=
  Σ ;;; Γ |- T <=[pb] T'.

Notation ws_decl Γ d := (on_free_vars_decl (shiftnP #|Γ| xpred0) d).

Definition open_decl (Γ : context) := { d : context_decl | ws_decl Γ d }.
Definition open_decl_proj {Γ : context} (d : open_decl Γ) := proj1_sig d.
Coercion open_decl_proj : open_decl >-> context_decl.

Definition vass_open_decl {Γ : closed_context} (na : binder_annot name) (t : open_term Γ) : open_decl Γ :=
  exist (vass na t) (proj2_sig t).

Definition ws_cumul_decls {cf : checker_flags} (pb : conv_pb) (Σ : global_env_ext)
  (Γ : context) (d : context_decl) (d' : context_decl) :=
  All_decls_alpha_pb pb (fun pb => @ws_cumul_pb cf pb Σ Γ) d d'.

Lemma ws_cumul_decls_wf_decl_left {cf} {pb} {Σ} {wfΣ : wf Σ} {Γ d d'} :
  ws_cumul_decls pb Σ Γ d d' -> ws_decl Γ d.
Proof.
  intros []; cbn; eauto with fvs.
Qed.

Lemma ws_cumul_decls_wf_decl_right {cf} {pb} {Σ} {wfΣ : wf Σ} {Γ d d'} :
  ws_cumul_decls pb Σ Γ d d' -> ws_decl Γ d'.
Proof.
  intros []; cbn; eauto with fvs.
Qed.
#[global] Hint Immediate ws_cumul_decls_wf_decl_left ws_cumul_decls_wf_decl_right : fvs.

Lemma ws_cumul_decls_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ}
  {Γ Γ' : context} {d d'} :
  ws_cumul_decls pb Σ Γ d d' ->
  cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d'.
Proof.
  intros. intuition eauto with fvs.
  destruct X; destruct pb; constructor; pcuic.
Qed.

Lemma into_ws_cumul_decls {cf : checker_flags} {pb : conv_pb} {Σ : global_env_ext} {wfΣ : wf Σ}
  (Γ Γ' : context) d d' :
  cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d' ->
  on_free_vars_ctx xpred0 Γ ->
  on_free_vars_ctx xpred0 Γ' ->
  is_open_decl Γ d ->
  is_open_decl Γ d' ->
  ws_cumul_decls pb Σ Γ d d'.
Proof.
  case: pb; move=> pb clΓ clΓ' isd isd';
    destruct pb; cbn; constructor; auto; try inv_on_free_vars; eauto with fvs.
  all:try apply: into_ws_cumul_pb; tea; eauto 3 with fvs.
Qed.

Lemma ws_cumul_decls_inv {cf} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ}
  {Γ Γ' : context} {d d'} :
  ws_cumul_decls pb Σ Γ d d' ->
  [× on_free_vars_ctx xpred0 Γ, is_open_decl Γ d, is_open_decl Γ d' & cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d'].
Proof.
  intros. split; eauto with fvs.
  - destruct X; now destruct eqt.
  - now eapply ws_cumul_decls_cumul_pb_decls.
Qed.

#[global]
Instance ws_cumul_decls_trans {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} :
  Transitive (ws_cumul_decls pb Σ Γ).
Proof.
  intros d d' d''.
  rewrite /ws_cumul_decls.
  intros ond ond'; destruct ond; depelim ond'.
  econstructor; now etransitivity.
  econstructor; etransitivity; tea.
Qed.

Inductive wt_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) : context_decl -> context_decl -> Type :=
| wt_cumul_pb_vass {na na' : binder_annot name} {T T' : term} :
    isType Σ Γ T -> isType Σ Γ' T' ->
    conv_cum pb Σ Γ T T' ->
    eq_binder_annot na na' ->
    wt_cumul_pb_decls pb Σ Γ Γ' (vass na T) (vass na' T')
| wt_cumul_pb_vdef {na na' : binder_annot name} {b b' T T'} :
    eq_binder_annot na na' ->
    isType Σ Γ T -> isType Σ Γ' T' ->
    Σ ;;; Γ |- b : T -> Σ ;;; Γ' |- b' : T' ->
    Σ ;;; Γ |- b = b' ->
    conv_cum pb Σ Γ T T' ->
    wt_cumul_pb_decls pb Σ Γ Γ' (vdef na b T) (vdef na' b' T').
Derive Signature for wt_cumul_pb_decls.

Definition ws_cumul_ctx_pb {cf:checker_flags} (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) :=
  All2_fold (fun Γ Γ' => ws_cumul_decls pb Σ Γ) Γ Γ'.

Notation "Σ ⊢ Γ ≤[ pb ] Δ" := (ws_cumul_ctx_pb pb Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  ≤[ pb ]  Δ") : pcuic.

Notation "Σ ⊢ Γ = Δ" := (ws_cumul_ctx_pb Conv Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  =  Δ") : pcuic.

Notation "Σ ⊢ Γ ≤ Δ" := (ws_cumul_ctx_pb Cumul Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  ≤  Δ") : pcuic.

Lemma ws_cumul_ctx_pb_closed_right {cf:checker_flags} {pb : conv_pb} {Σ} {wfΣ : wf Σ} {Γ Γ'}:
  ws_cumul_ctx_pb pb Σ Γ Γ' -> is_closed_context Γ'.
Proof.
  intros X. red in X.
  induction X; auto.
  rewrite on_free_vars_ctx_snoc IHX /= //.
  rewrite -(All2_fold_length X); eauto with fvs.
Qed.

Lemma ws_cumul_ctx_pb_closed_left {cf:checker_flags} {pb : conv_pb} {Σ} {wfΣ : wf Σ} {Γ Γ'}:
  ws_cumul_ctx_pb pb Σ Γ Γ' -> is_closed_context Γ.
Proof.
  intros X. red in X.
  induction X; auto.
  rewrite on_free_vars_ctx_snoc IHX /=.
  eauto with fvs.
Qed.

#[global] Hint Resolve ws_cumul_ctx_pb_closed_left ws_cumul_ctx_pb_closed_right : fvs.

Definition wt_cumul_ctx_pb {cf:checker_flags} (pb : conv_pb) (Σ : global_env_ext) :=
  All2_fold (wt_cumul_pb_decls pb Σ).

Notation "Σ ⊢ Γ ≤[ pb ] Δ ✓" := (wt_cumul_ctx_pb pb Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  ≤[ pb ]  Δ  ✓") : pcuic.

Notation wt_cumul_context Σ := (wt_cumul_ctx_pb Cumul Σ).
Notation wt_conv_context Σ := (wt_cumul_ctx_pb Conv Σ).

Section WtContextConversion.
  Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Definition wt_decl Γ d :=
    match d with
    | {| decl_body := None; decl_type := ty |} => isType Σ Γ ty
    | {| decl_body := Some b; decl_type := ty |} => isType Σ Γ ty × Σ ;;; Γ |- b : ty
    end.

  Lemma wf_local_All_fold Γ :
    wf_local Σ Γ <~>
    All_fold wt_decl Γ.
  Proof using Type.
    split.
    - induction 1; constructor; auto.
      red in t0, t1. cbn. split; auto.
    - induction 1; [constructor|].
      destruct d as [na [b|] ty]; cbn in p; constructor; intuition auto.
  Qed.

  Lemma wt_cumul_ctx_pb_forget {pb} {Γ Γ' : context} :
    wt_cumul_ctx_pb pb Σ Γ Γ' ->
    [× wf_local Σ Γ, wf_local Σ Γ' & cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'].
  Proof using Type.
    move=> wteq.
    eapply (All2_fold_impl (Q:=fun Γ Γ' d d' => wt_decl Γ d × wt_decl Γ' d' × cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d')) in wteq.
    2:{ intros ???? []; intuition (cbn; try constructor; auto). }
    eapply All2_fold_All_fold_mix_inv in wteq as [wteq [wfΓ wfΓ']].
    eapply wf_local_All_fold in wfΓ. eapply wf_local_All_fold in wfΓ'.
    split; auto.
  Qed.

  Lemma into_wt_cumul_ctx_pb {pb} {Γ Γ' : context} {T U : term} :
    wf_local Σ Γ -> wf_local Σ Γ' ->
    cumul_pb_context cumulAlgo_gen pb Σ Γ Γ' ->
    wt_cumul_ctx_pb pb Σ Γ Γ'.
  Proof using Type.
    move=> /wf_local_All_fold wfΓ /wf_local_All_fold wfΓ'.
    destruct pb=> eq.
    eapply All2_fold_All_fold_mix in eq; tea.
    eapply All2_fold_impl; tea; clear => Γ Γ' d d' [wtd [wtd' cum]] /=.
    destruct cum; cbn in wtd, wtd'; constructor; intuition auto.
    eapply All2_fold_All_fold_mix in eq; tea.
    eapply All2_fold_impl; tea; clear => Γ Γ' d d' [wtd [wtd' cum]] /=.
    destruct cum; cbn in wtd, wtd'; constructor; intuition auto.
  Qed.

  Lemma wt_ws_ws_cumul_ctx_pb {pb} {Γ Γ' : context} {T U : term} :
    wt_cumul_ctx_pb pb Σ Γ Γ' ->
    ws_cumul_ctx_pb pb Σ Γ Γ'.
  Proof using wfΣ.
    intros a; eapply All2_fold_impl_ind; tea.
    intros ???? wt ws eq;
    pose proof (All2_fold_length wt).
    destruct eq.
    - pose proof (isType_wf_local i).
      eapply wf_local_closed_context in X.
      eapply isType_open in i. apply isType_open in i0.
      eapply into_ws_cumul_decls with Δ; eauto with fvs.
      constructor; auto.
      rewrite (All2_fold_length ws) //.
    - pose proof (isType_wf_local i).
      eapply wf_local_closed_context in X.
      eapply isType_open in i. apply isType_open in i0.
      eapply PCUICClosedTyp.subject_closed in t.
      eapply PCUICClosedTyp.subject_closed in t0.
      eapply (@closedn_on_free_vars xpred0) in t.
      eapply (@closedn_on_free_vars xpred0) in t0.
      eapply into_ws_cumul_decls with Δ; eauto with fvs.
      destruct pb; constructor; auto.
      rewrite (All2_fold_length ws) //; eauto with fvs.
  Qed.

  Lemma ws_cumul_ctx_pb_inv {pb} {Γ Γ' : context} :
    ws_cumul_ctx_pb pb Σ Γ Γ' ->
    [× on_free_vars_ctx xpred0 Γ, on_free_vars_ctx xpred0 Γ' & cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'].
  Proof using wfΣ.
    move=> wteq.
    split; eauto with fvs.
    eapply All2_fold_impl; tea; move=> ???? []; constructor; eauto with pcuic.
    all:try now eapply ws_cumul_pb_forget in eqt.
  Qed.

  #[global]
  Instance ws_cumul_decls_sym Γ : Symmetric (ws_cumul_decls Conv Σ Γ).
  Proof using Type.
    move=> x y [na na' T T' eqan cv|na na' b b' T T' eqna eqb eqT];
    constructor; now symmetry.
  Qed.

  Lemma ws_cumul_ctx_pb_forget {pb Γ Γ'} :
    ws_cumul_ctx_pb pb Σ Γ Γ' -> cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'.
  Proof using wfΣ.
    now move/ws_cumul_ctx_pb_inv => [].
  Qed.

  Lemma ws_cumul_ctx_pb_refl pb Γ : is_closed_context Γ -> ws_cumul_ctx_pb pb Σ Γ Γ.
  Proof using wfΣ.
    move=> onΓ. cbn.
    move/on_free_vars_ctx_All_fold: onΓ => a.
    eapply (All_fold_All2_fold_impl a). clear -wfΣ.
    move=> Γ d a IH ond.
    move/on_free_vars_ctx_All_fold: a => clΓ.
    eapply (into_ws_cumul_decls _ Γ); auto.
    destruct d as [na [b|] ty]; constructor; auto; reflexivity.
  Qed.

End WtContextConversion.


From Undecidability.TM Require TM_facts ProgrammingTools CaseList CaseBool.
From Complexity.TM Require Code.Decode Code.DecodeList.

From Undecidability.TM Require Import TM.
From Complexity.TM.PrettyBounds Require Import SizeBounds.

From Undecidability.L.Complexity  Require Import UpToCNary.
From Complexity.NP.L  Require Import LMGenNP.

From Undecidability.L.AbstractMachines Require Import FlatPro.Programs.
From Complexity.L.AbstractMachines Require Import FlatPro.Computable.Compile.

Unset Printing Coercions.

From Undecidability.TM.L Require Alphabets M_LHeapInterpreter.

From Coq Require Import Lia Ring Arith.

From Undecidability.TM.L Require Import Boollist_to_Enc.

From Complexity.L.AbstractMachines Require SizeAnalysisStep LMBounds_Loop.

Set Default Proof Using "Type".

Import DecodeList Decode.
Module LMtoTM.
  Section sec.
    Import ProgrammingTools Combinators M_LHeapInterpreter.

    Variable (sig : finType).

    Context `{retr__LAM : Retract sigStep sig}
            `{retr__list : Retract (sigList bool) sig}.

    Definition retr__listHClos : Retract (sigList Alphabets.sigHClos) sig
      := ComposeRetract retr__LAM retr_closures_step.

    Definition retr__Heap : Retract Alphabets.sigHeap sig
    := ComposeRetract retr__LAM retr_heap_step.

    Definition retr__HClos : Retract Alphabets.sigHClos sig :=
      ComposeRetract retr__listHClos _.

    Definition retr__pro : Retract Alphabets.sigPro sig := ComposeRetract retr__HClos _.

    Definition retr__nat : Retract sigNat sig:= ComposeRetract retr__pro _.

    Definition Rel : pRel (sig ^+) bool 11 :=
      fun tin '(y,tout) =>
        forall (P:Pro),
        tin[@Fin1] ≃(retr__pro) P ->
        (forall i : Fin.t 9, isVoid tin[@FinR 2 i])
        -> match y with
            false => ~ exists (bs:list bool), tin[@Fin0] ≃ bs
          | true => exists (bs : list bool),
                   tin[@Fin0] ≃ bs
                   /\ exists sigma' k, ARS.evaluatesIn LM_heap_def.step k (initLMGen P (compile (Extract.enc (rev bs)))) sigma'
          end.
(* initLMGen = n s c : list Tok => ([(0, s ++ c ++ [appT])], [], []) *)
    Import Boollist_to_Enc ListTM Alphabets StepTM.

    Definition M : pTM sig ^+ bool 11 :=
      If (CheckEncodesBoolList.M _ @ [|Fin0|])
         (Return (F:=FinType (EqType unit)) (LiftTapes (BoollistToEnc.M _ retr__pro) [|Fin0;Fin2;Fin3;Fin4 |];; (* 0:right, 2:compile (enc (rev b)), 3,4:right*)
                  LiftTapes (ChangeAlphabet (WriteValue ([appT])) retr__pro) [| Fin3|];; (*3:[appT]*)
                  LiftTapes (ChangeAlphabet (App' _ ) retr__pro) [|Fin2;Fin3|];; (*3:compile (rev b)++[appT]*)
                  LiftTapes (ChangeAlphabet (App' _) retr__pro) [|Fin1;Fin3|];; (*3:P++compile (rev b)++[appT]*)
                  LiftTapes (ChangeAlphabet (WriteValue ((@nil (LM_heap_def.HClos)))) retr__listHClos) [| Fin0|];; (*0:[]*)
                  LiftTapes (ChangeAlphabet (WriteValue (0)) (StepTM.retr_nat_step_clos_ad retr__listHClos)) [| Fin5|];; (*5:0*)
                  LiftTapes (StepTM.ConsClos retr__listHClos) [|Fin0;Fin5;Fin3 |];; (* 0: initLMGen, 5,3:right *)
                  LiftTapes (Reset _) [|Fin1|];;
                  LiftTapes (Reset _) [|Fin2|];;(*1,2: right*)
(*1,2: empty*)
                  LiftTapes (ChangeAlphabet (WriteValue ((@nil (LM_heap_def.HClos)))) retr__listHClos) [| Fin1|];; (*1:[]*)
                  LiftTapes (ChangeAlphabet (WriteValue ((@nil (LM_heap_def.HEntr)))) retr__Heap) [| Fin2|];; (*2:[]*)
                  ChangeAlphabet M_LHeapInterpreter.Loop retr__LAM )
                 true)
         (Return Nop false).

    Definition Ter time: tRel sig^+ 11 :=
      (fun tin k =>
         exists (P:Pro) steps__LM,
           tin[@Fin1] ≃(retr__pro) P /\
           (forall i : Fin.t 9, isVoid tin[@FinR 2 i])
           /\ (((~exists (bs : list bool), tin[@Fin0] ≃ bs) /\ steps__LM = 0)
             \/
             exists (bs : list bool),
               tin[@Fin0] ≃ bs
               /\ exists sigma', ARS.evaluatesIn LM_heap_def.step steps__LM (initLMGen P (compile (Extract.enc (rev bs)))) sigma')
           /\ time (steps__LM,sizeOfmTapes tin) <= k).

    Import MoreList.
    Import FlatPro.SizeAnalysisStep TM_LHeapInterpreter.LMBounds_Loop.

    Lemma size_compile_list_bool:
      (fun bs : list bool => Code.size (compile (Extract.enc (rev bs)))) <=c (fun bs => length bs + 1).
    Proof.
      (* From Undecidability.L.AbstractMachines.TM_LHeapInterpreter Require  *)
      evar (c:nat). exists c. intros xs.
      rewrite size_le_sizeP. unfold sizeP;rewrite sizeP_size,Lists.size_list.
      rewrite map_rev,<-sumn_rev. rewrite MoreBase.sumn_le_bound.
      2:{ intros ? ([]&<-&?)%in_map_iff. all:cbv. reflexivity. nia. }
      rewrite map_length. ring_simplify. [c]:exact 54. unfold Lists.c__listsizeNil. nia.
    Qed.

    Ltac fin_inst_all H :=
      match type of H with
        forall i : Fin.t 0 , _ => clear H
      | forall i : Fin.t (S ?n) , @?P i =>
        let tmp := fresh "_tmp" in
        let H':= fresh H in
        rename H into _tmp;
        assert (H':= tmp Fin0);
        assert (H:= fun i => tmp (Fin.FS i));clear tmp;
        fin_inst_all H
      end.

    Local Arguments sizeOfmTapes : simpl never.
    Definition _Terminates :
      { time : UpToC ((fun '(steps, size) => (steps + 1) * (steps + size + 1) ^3 ))
               & projT1 M ↓ Ter time}.
    Proof.
      eexists_UpToC time.
      eapply TerminatesIn_monotone.
      { unfold M. TM_Correct.
        all: eauto 2 using App'_Terminates,App'_Realise,BoollistToEnc.Realise,ConsClos_Realise,ConsClos_Terminates,Loop_Terminates.
        all: try now (notypeclasses refine (@Reset_Terminates _ _ _ _ _);shelve).
        all: try now (notypeclasses refine (@Reset_Realise _ _ _ _ _);shelve).
        1:notypeclasses refine (CheckTapeContains.Realise _ _).
        3:notypeclasses refine (CheckTapeContains.Terminates _ _).
        4:apply CheckEncodesBoolList.Terminates'.
        1,3:apply CheckEncodesBoolList.Realise';now destruct x.
        now apply list_encode_prefixInjective,DecodeBool.bool_encode_prefixInjective.
        apply BoollistToEnc.Terminates.
      }
      intros tin k H. hnf in H. destruct H as (P&steps__LM&HP&Hrem&Hsteps&Hk).
      cbn -[plus mult]. infTer 5.
      1:erewrite length_tape_local_right,right_sizeOfTape; rewrite <- Hk.
      2:{ intros tout b [[[Hb1] Hb2] Hrem']. fin_inst_all Hrem. TMSimp.
          destruct Hb1 as [(bs&Hbs) | ]. 2: now apply Nat.le_0_l.
          destruct Hsteps as [ [[] _] | Hsteps].
          { eexists. contains_ext. }
          destruct Hsteps as (bs'&Hbs'&Hsteps).
          replace bs' with bs in *.
          2:{
            destruct Hbs as [? Hbs]. destruct Hbs' as [? Hbs']. rewrite Hbs' in Hbs. inv Hbs.
            rewrite !map_map in H1. eapply app_inv_tail, map_injective in H1.
            2:{ intros ? ? [= ]. now eapply retract_f_injective. }
            apply encode_list_injective in H1. easy. apply Encode_bool_injective.
          }
          clear bs' Hbs'.
          set (sizeM := sizeOfmTapes [|tin_0; tin_1; tin_2; tin_3; tin_4; tin_5; tin_6; tin_7; tin_8; tin_9; tin_10|]).
          assert (Hlebs : length bs <= sizeM).
          { clear - Hbs. unfold sizeM. rewrite <- sizeOfmTapes_upperBound with (t:=tin_0).
           2:now eapply vect_nth_In with (i:=Fin0).
           destruct Hbs as (rem&->). cbn.  rewrite encode_list_concat. repeat (autorewrite with list;cbn).
           rewrite length_concat. rewrite map_map;cbn. rewrite sumn_map_c. nia. }
          modpon Hb2;[]. infTer 3. 2:easy.
          {hnf. cbn. TMSimp. exists bs. repeat simple apply conj. easy. 1-3:try isVoid_mono.
           erewrite UpToC_le. rewrite Hlebs. reflexivity. }
          intros t1_ _ (HP'&Hrem_1). specialize (HP' bs). TMSimp. modpon HP'.
          infTer 5. TMSimp_goal. intros t2_ _ (Ht2&Ht2Rem). modpon Ht2.
          (*unfold tapes in tin,tout,t1 |-. destruct_vector. cbn [Vector.nth Vector.caseS] in *. all:subst. *)
          TMSimp.

          infTer 5.
          {hnf;cbn. eexists _ (*(compile (Extract.enc (rev bs)))*),[appT]. repeat simple apply conj. 1-2:now simpl_surject;try contains_ext.
           setoid_rewrite ((proj2_sig (BaseCode.App'_steps_nice _) _) : _ <= _).

           rewrite (correct__leUpToC size_compile_list_bool), Hlebs. reflexivity.
          }
          intros t3_ _ (Ht3&Ht3Rem). specialize (Ht3 (compile (Extract.enc (rev bs))) [appT]). modpon Ht3;[]. TMSimp.
          infTer 5.
          { hnf;cbn. eexists _, _. repeat simple apply conj. 1-2:now simpl_surject;try contains_ext.
            eassert (H':=proj2_sig (BaseCode.App'_steps_nice _) P).
            hnf in H'. rewrite H'. reflexivity. }
          intros t4_ _ (Ht4&Ht4Rem). specialize (Ht4 P (compile (Extract.enc (rev bs)) ++ [appT])). TMSimp.
          modpon Ht4; [].
          infTer 5. intros t5_ _ (Ht5&Ht5Rem). modpon Ht5;[].
          infTer 5. intros t6_ _ (Ht6&Ht6Rem). TMSimp. modpon Ht6;[].
          infTer 5.
          { hnf;cbn. eexists _,_,_. repeat simple apply conj. 1-3:now simpl_surject;try contains_ext.
            match goal with |- _ <= ?c' => set (c:=c') end.
            unfold CaseList.Constr_cons_steps, Reset_steps. ring_simplify.
            setoid_rewrite Encode_pair_hasSize. cbn - [plus mult].
            repeat setoid_rewrite @BaseCode.encodeList_size_app.
            unfold c.
            rewrite (correct__leUpToC size_compile_list_bool), Hlebs. reflexivity.
          }
          intros t7_ _ (Ht7&Ht7Rem). modpon Ht7 . progress TMSimp.
          infTer 4. now contains_ext. reflexivity.
          intros t8_ _ (Ht8'&Ht8Rem). modpon Ht8'. TMSimp.
          (*move Hsteps at bottom. destruct Hsteps as [ [H' ->] | H' ].
          { edestruct move H' destruct H'. }*)
          infTer 3.
          { split. now contains_ext. unfold Reset_steps.
            rewrite (correct__leUpToC size_compile_list_bool), Hlebs.  reflexivity. }
          reflexivity.
          intros t9_ _ (Ht9'&Ht9Rem). modpon Ht9'.
          infTer 4. intros t10 _ (Ht10&Ht10Rem). TMSimp.
          modpon Ht10.
          infTer 4. intros t11 _ (Ht11&Ht11Rem). specialize Ht11. modpon Ht11. TMSimp.
          hnf. eexists [(0,_)],[],[],_. repeat eapply conj.
          -eexists. eassumption.
          -cbn. simpl_surject. TMSimp_goal. contains_ext.
          -cbn. simpl_surject. TMSimp_goal. contains_ext.
          -cbn. simpl_surject. TMSimp_goal. contains_ext.
          -intros i. cbn. destruct_fin i;cbn. all:simpl_surject. all:isVoid_mono.
          -unshelve erewrite (correct__leUpToC Loop_steps_nice (_,_)).
           cbn [length]. unfold sizeP. rewrite !map_app,!sumn_app.

           rewrite (correct__leUpToC sizeT_compile_list_bool bs).
           set (c:= sumn (map sizeT [appT])); cbv in c; subst c.
           rewrite !Nat.add_assoc.
           set (c':= c__leUpToC) at 3.
           replace ((sumn (map sizeT P) + c' * ((| bs |) + 1) + 1 + 1))
              with (sizeP P + c' * ((| bs |) + 1) + 1) by (unfold sizeP;lia).
          replace (steps__LM + sumn (map sizeT P) + c__leUpToC * ((| bs |) + 1) + 1 + 1)
            with (steps__LM + sizeP P + c' * ((| bs |) + 1) + 1) by (unfold sizeP;lia).
           rewrite Hlebs. reflexivity.
      }
      ring_simplify.
      unfold Reset_steps.
      setoid_rewrite (sizeP_le_size P).
      repeat rewrite sizeOfTape_tape_contains_size with (1:=(tape_contains_contains_size HP)).
      repeat rewrite sizeOfmTapes_upperBound with (tps:=tin). 2-3:now eapply vect_nth_In.
      [time]:refine (fun '(steps__LM,sizeM) => _).
      set (sizeM := sizeOfmTapes _). unfold time. reflexivity.
      unfold time. clear time.
      set (c':=c__leUpToC). set (c'':=c__leUpToC). set (c''':=c__leUpToC).
      clearbody c'. clearbody c''. clearbody  c'''.
      (* nary simple apply (upToC_mul_c_r__out_nary (c:=(c''+1)^2*((c'''+1)^2))). nia. *)
      smpl_upToC.
      all:cbn [Nat.pow];try now smpl_upToC_solve.
    Qed.

    Definition Terminates := projT2 _Terminates.

    Definition Realise : M ⊨ Rel.
    Proof.
      unfold M. eapply Realise_monotone.
      { TM_Correct.
        1:{  notypeclasses refine (CheckTapeContains.Realise _ _).
             eapply CheckEncodesBoolList.Realise'. now destruct x.
             now eapply list_encode_prefixInjective,DecodeBool.bool_encode_prefixInjective. }
        now apply BoollistToEnc.Realise.
        all:try now simple apply App'_Realise.
        now apply ConsClos_Realise.
        all:try now (notypeclasses refine (@Reset_Realise _ _ _ _ _);shelve).
        now simple apply Loop_Realise.
      }
      intros tin (yout,tout) H. hnf in H|-*. cbn in H.
      intros P HP HRem.
      destruct H as [H|H].
      2:{destruct H as (?&H&->&_&->). destruct H as (([Hx]&Hx')&Hrem). inv Hx. easy. }
      destruct H as (t1&Hcond&H). destruct Hcond as (([Hx]&Hx')&Hrem).
      (*fin_inst_all HRem. cbn [FinR] in *.   *)
      modpon Hx'. inv Hx'.
      inv Hx. destruct H0 as (bs&Hx). TMSimp.
      do_n_times_fin 9 ltac:(fun i => let H := fresh "HRem" in specialize (HRem i) as H;cbn in H);clear HRem.
      modpon H0.
      eexists bs. split. contains_ext.
      modpon H2;[]. modpon H4;[].
      modpon H6;[].
      modpon H8;[].
      modpon H10;[].
      modpon H12;[]. modpon H14;[]. modpon H16;[].
      modpon H18;[].
      modpon H20;[].
      rename H11 into H11',H22 into H11.
      specialize (H11 (fst (fst (initLMGen P (compile (Extract.enc (rev bs)))))) [] []).
      cbn in H11. TMSimp.
      modpon H11.
      1:{ instantiate (1:= [| _;_;_;_;_;_;_;_|]).
          intros i. destruct_fin i;cbn;simpl_surject;eauto.
      }
      destruct H11 as (T'&V'&H'&k&Hred&HHalt&_).
      exists (T',V',H'),k. split. exact Hred. exact HHalt.
    Qed.

  End sec.
End LMtoTM.


(* begin hide *)

From mathcomp Require Import all_ssreflect.

Require Import String.
Require Import QString.

Require Import Value.

Require Import Schema.
Require Import SchemaAux.
Require Import SchemaWellFormedness.

Require Import Graph.
Require Import GraphConformance.

Require Import Query.
Require Import QueryAux.
Require Import QueryConformance.

Require Import Response.

Require Import QuerySemantics.

(* end hide *)

Open Scope string_scope.

Section Values.

  Inductive Scalar : Type :=
  | VInt : nat -> Scalar
  | VBool: bool -> Scalar
  | VString : string -> Scalar
  | VFloat : nat -> nat -> Scalar.

  (** We need to prove that Value has a decidable equality procedure,
      we hide it to unclutter the docs
   *)
  (* begin hide *)
  Notation vtype := (nat + bool + string + (nat * nat))%type.

  Definition tuple_of_scalar (v : Scalar) :=
    match v with
    | VInt n => inl (inl (inl n))
    | VBool b => inl (inl (inr b))
    | VString s => inl (inr s)
    | VFloat n1 n2 => inr (n1, n2)
    end.

  Definition scalar_of_tuple (t : vtype) : Scalar :=
    match t with
    | inl (inl (inl n)) => VInt n
    | inl (inl (inr b)) => VBool b
    | inl (inr s) => VString s
    | inr (n1, n2) => VFloat n1 n2
    end.

  Lemma tuple_of_scalarK : cancel tuple_of_scalar scalar_of_tuple.
  Proof. by case; case.
  Qed.

  Canonical scalar_eqType := EqType Scalar (CanEqMixin tuple_of_scalarK).
  (* end hide *)

  Definition coerce : Scalar -> Scalar := id.

  Variable (schema : graphQLSchema).
  Fixpoint check_scalar (ty : type) (v : Scalar) : bool :=
    match v with
    | VInt _ => if ty is NamedType name then
                 (name == "Int") || (name == "ID")
               else
                 false

    | VBool _ => if ty is NamedType name then
                  name == "Boolean"
                else
                  false

    | VString s => if ty is NamedType name then
                    (name == "String")
                    ||
                    if lookup_type schema name is Some (enum _ { members }) then
                      s \in members
                    else
                      false
                  else
                    false

    | VFloat _ _ => if ty is NamedType name then
                     name == "Float"
                   else
                     false
    end.

End Values.

Section WrongGraph.

  Coercion namedType_of_string (s : string) := NamedType s.

  Let IDType := scalar "ID".
  Let StringType := scalar "String".
  Let FloatType := scalar "Float".

  Let StarshipType := object "Starship" implements [::] {
                              [:: Schema.Field "id" [::] "ID";
                                  Schema.Field "name" [::] "String";
                                  Schema.Field "length" [::] "Float"
                              ]
                            }.

  Let CharacterType := interface "Character" {
                                  [::
                                     Schema.Field "id" [::] "ID" ;
                                     Schema.Field "name" [::] "String";
                                     Schema.Field "friends" [::] [ "Character" ]
                                    ]
                                  }.

  Let DroidType := object "Droid" implements [:: "Character"] {
                           [::
                              Schema.Field "id" [::] "ID" ;
                              Schema.Field "name" [::] "String";
                              Schema.Field "friends" [::] [ "Character" ];
                              Schema.Field "primaryFunction" [::] "String"
                           ]
                         }.

  Let HumanType := object "Human" implements [:: "Character"] {
                           [::
                              Schema.Field "id" [::] "ID" ;
                              Schema.Field "name" [::] "String";
                              Schema.Field "friends" [::] [ "Character" ];
                              Schema.Field "starships" [::] [ "Starship" ]
                           ]
                         }.

  Let EpisodeType := enum "Episode" { [:: "NEWHOPE" ; "EMPIRE" ; "JEDI" ] }.

  Let SearchResultType := union "SearchResult" { [:: "Human" ; "Droid" ; "Starship"] }.

  Let QueryType := object "Query" implements [::] {
                           [::
                              Schema.Field "hero" [:: FieldArgument "episode" "Episode"] "Character";
                              Schema.Field "search" [:: FieldArgument "text" "String"] [ "SearchResult" ]
                           ]
                         }.

  Let schema  := GraphQLSchema "Query"  [:: IDType; StringType; FloatType;  StarshipType;  CharacterType; DroidType; HumanType; EpisodeType; SearchResultType; QueryType].

  Lemma sdf : schema.(is_a_wf_schema).
  Proof. by []. Qed.

  Let wf_schema : wfGraphQLSchema := WFGraphQLSchema sdf.

  (** Some examples of graph's not conforming to the schema **)

  Let r : @node scalar_eqType := Node "Query" [::].

  (** Root node does not have same type as query type **)
  Let edges1 : seq (@node scalar_eqType * @label scalar_eqType * @node scalar_eqType) := [::].

  Let r1 : @node scalar_eqType := Graph.Node "Human" [::].

  Let g := GraphQLGraph r1 edges1.

  (** Arguments are incorrect **)

  Let edges2 : seq (@node scalar_eqType * @label scalar_eqType * @node scalar_eqType) :=
    [:: (pair
           (pair
              (Node "Query" [::])

              (Label "search" [:: pair "wrong_Arg" (SValue (VString "L"))]))          (* <--- Wrong name for argument *)

           (Node "Starship" [::
                               (pair (Label  "id" [::]) (SValue (VInt 3000)));
                               (pair (Label "name" [::]) (SValue (VString "Falcon")));
                               (pair (Label "length" [::]) (SValue (VFloat 34 37)))
                            ]
           )
        )
    ].

  Let g2 := GraphQLGraph r edges2.

  Example eNc : ~ edges_conform wf_schema check_scalar g2.
  Proof. by [].
  Qed.

  (** Types are incorrect **)

  Let edges3 : seq (@node scalar_eqType * @label scalar_eqType * @node scalar_eqType) :=
    [:: pair
        (pair (Node "Human" [::
                               (pair (Label "id" [::]) (SValue (VInt 1000)));
                               (pair (Label "name" [::]) (SValue (VString "Luke")))
                            ]
              )
              (Label "friends" [::])
        )
        (Node "Starship" [::
                            (pair (Label "id" [::]) (SValue (VInt 2001)));
                            (pair (Label "name" [::]) (SValue (VString "R2-)D2")));
                            (pair (Label "primaryFunction" [::]) (SValue (VString "Astromech")))
                         ]
        )
    ].

  Let r3 : @node string_eqType := Node "Query" [::].

    Let g3 := GraphQLGraph r edges3.

    Example eNc3 : ~ edges_conform wf_schema check_scalar g3.
    Proof. by [].
    Qed.

    Let edges4 : seq (@node scalar_eqType * label * node) :=
      [:: pair
          (pair (Node "Query" [::])
                (Label "search" [:: (pair "wrong_Arg" (SValue (VString "L")))])
          )
          (Node "Other" [::
                           (pair (Label "id" [::]) (SValue (VInt 3000))); (* <--- Type is not in union *)
                           (pair (Label "name" [::]) (SValue (VString "Falcon")));
                           (pair (Label "length" [::]) (SValue (VFloat 34 37)))
                        ]
          )
      ].

    Let r4 : @node scalar_eqType := Node "Query" [::].

    Let g4 := GraphQLGraph r edges4.

    Example eNc4 : ~ edges_conform wf_schema check_scalar g4.
    Proof. by [].
    Qed.

    (** Label's are incorrect **)

    Let edges5 : seq (@node scalar_eqType * @label scalar_eqType * @node scalar_eqType) :=
      [:: pair
          (pair (Node "Query" [::])
                (Label "search" [:: (pair "wrong_Arg" (SValue (VString "L")))])
          )
          (Node "Starship" [::
                              (pair (Label "id" [::]) (SValue (VInt 3000)));
                              (pair (Label "name" [:: (pair "wrong" (SValue (VString "arg")))]) (SValue (VString "Falcon"))); (* <--- invalid argument in field*)
                              (pair (Label "length" [::]) (SValue (VFloat 34 37)))
                           ]
          )
      ].

    Let g5 := GraphQLGraph r edges5.

    Example fNc : ~ nodes_conform wf_schema check_scalar g5.(nodes).
    Proof. by [].
    Qed.

End WrongGraph.


From iris.proofmode Require Import tactics.
From trace_program_logic.program_logic Require Export adequacy.
From aneris.aneris_lang Require Import
     aneris_lang network resources.
From aneris.prelude Require Import gmultiset.
From aneris.aneris_lang.state_interp Require Import
     state_interp_def
     state_interp_local_coh
     state_interp_gnames_coh
     state_interp_free_ips_coh
     state_interp_network_sockets_coh
     state_interp_socket_interp_coh
     state_interp_messages_resource_coh
     state_interp_messages_history_coh
     state_interp_events
     state_interp_messages_history.

From RecordUpdate Require Import RecordSet.
Set Default Proof Using "Type".

Import uPred.
Import RecordSetNotations.

Section state_interpretation.
  Context `{!anerisG Mdl Σ}.

  Lemma config_wp_correct : ⊢ config_wp.
  Proof.
    rewrite /config_wp. iIntros. iModIntro.
    iIntros (ex atr c σ2 Hexvalid Hex Hstep) "(Hevs & Hsi & Hm)". simpl.
    rewrite /state_interp; simplify_eq /=.
    rewrite (last_eq_trace_ends_in ex c) /=; last done.
    iDestruct "Hsi" as (γm mh)
           "(%Hhist & %Hgcoh & %Hnscoh & %Hmhcoh
                    & Hnauth & Hsi & Hlcoh & Hfreeips & Hmctx & Hmres)".
    iApply step_fupd_fupd; iApply step_fupd_intro; first done.
    destruct c as [tp1 σ1]; simpl in *.
    iExists (trace_last atr), ().
    iIntros "!> !>".
    rewrite (aneris_events_state_interp_same_tp _ (tp1, _)); [| |done|done]; last first.
    { econstructor; [done| |done]. econstructor 2; eauto. }
    pose proof Hstep as Hstep'.
    inversion Hstep as [ip σ Sn Sn' sh a skt R m Hm HSn Hsh HSn' Hsaddr | σ];
      simplify_eq/=.
    - iFrame "Hm Hevs".
      iSplit; first by iPureIntro; left.
      iExists γm, mh. iFrame "Hsi".
      iSplit.
      { erewrite  <- message_history_evolution_deliver_message; eauto with set_solver. }
      iSplitR; [eauto using gnames_coh_update_sockets|].
      iSplitR; [eauto using network_sockets_coh_deliver_message|].
      iSplitR; [eauto using messages_history_coh_deliver_message|].
      iFrame. iSplitL "Hlcoh".
      { by iApply (local_state_coh_deliver_message with "[Hlcoh]"). }
      iSplitL "Hfreeips". by iApply free_ips_coh_deliver_message.
      rewrite /messages_resource_coh. iApply (big_sepS_mono with "Hmres").
      iIntros (??) "[Hmr|%Hmr]"; last eauto with iFrame. iLeft.
      iDestruct "Hmr" as (phi) "(Hphi & Hphi2)". eauto with iFrame.
    - iSplit; first by iPureIntro; left.
      iFrame "Hevs Hm". iExists γm, mh. iFrame; simpl.
      iSplit.
      { iPureIntro.
        rewrite -message_history_evolution_drop_message; first done.
        apply gmultiset_difference_subseteq. }
      iSplitR; first done.
      iSplitR; first done.
      iSplitR; first by iPureIntro; eapply messages_history_drop_message.
      rewrite /messages_resource_coh. iApply (big_sepS_mono with "Hmres").
      iIntros (??) "[Hmr|%Hmr]"; last eauto with iFrame. iLeft.
      iDestruct "Hmr" as (phi) "(Hphi & Hphi2)". eauto with iFrame.
  Qed.

End state_interpretation.


(******************************************************************************)
(* Tactics for simplifying the goal state of proofs about LLVM IR programs.   *)
(******************************************************************************)

Require opsem.
Import opsem.Opsem.
Require ndopsem.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.ZArith.ZArith.
Require Import Tvc.base_tactics.
Require Import Tvc.notation.
Require Import Tvc.definitions.

Ltac destruct_all_eq_dec := autorewrite with eq_dec_db in *.

Lemma simplify_const2GV_int :
  forall td g v1 v2 gn gns b c d e,
    eq (opsem.Opsem.const2GV td g (const_int v1 v2)) (Some gns) ->
    gn @ gns ->
    _const2GV td g (const_int v1 v2) = Some ([(Values.Vint c d, e)], b) ->
    eq gn [(Values.Vint c d, e)].
Proof.
  intros.

  unfold opsem.Opsem.const2GV in H.
  destruct (_const2GV td g (const_int v1 v2)).

  injection H1; clear H1; intros; subst.
  injection H; clear H; intro; subst.
  inversion H0.
  trivial.

  discriminate.
Qed.

(*
This tactic eliminates corresponding pairs of const2GV and instantiate_gvs.
*)
Ltac simplify_const2GV :=
  repeat match goal with
           | [ H1 : eq (const2GV _ _ _) (Some ?x),
               H2 : opsem.instantiate_gvs _ _ ?x |- _ ] =>
             eapply simplify_const2GV_int in H1; [ | eassumption | compute; reflexivity ]; clear H2; subst; try clear x
           | [ H1 : eq (const2GV _ _ _) (Some ?x),
               H2 : ndopsem.MNDGVs.instantiate_gvs _ ?x |- _ ] =>
             eapply simplify_const2GV_int in H1; [ | eassumption | compute; reflexivity ]; clear H2; subst; try clear x

         end.

(*
This tactic reduces (instantiate_gvs _ x (Ensembles.Singleton _ y)) to x = y.
*)
Ltac simplify_instantiate_gvs_singleton :=
  repeat match goal with
           | [ H : opsem.instantiate_gvs _ ?x (Ensembles.Singleton _ ?y) |- _ ] =>
             destruct H
           | [ H : ndopsem.MNDGVs.instantiate_gvs ?x (Ensembles.Singleton _ ?y) |- _ ] =>
             destruct H
         end.

(*
This tactic eliminates equations involving getTypeAllocSize.
*)
Ltac simplify_getTypeAllocSize :=
  repeat match goal with
           | [ H : eq (getTypeAllocSize _ _) (Some ?x) |- _ ] =>
             compute in H; injection H; clear H; intro; subst x
         end.

Ltac simplify :=
  unfold BOP, TRUNC, EXT, ICMP, getOperandValue, alist.updateAddAL, alist.lookupAL in *;
  destruct_all_eq_dec;
  simplify_const2GV;
  simplify_instantiate_gvs_singleton;
  simplify_getTypeAllocSize;
  injection_Some_eq_Some;
  subst;
  simplify_instantiate_gvs_singleton;
  simpl in *.

Ltac simplify_memory_op id Hnew :=
  unfold alist.updateAddAL, BOP, getOperandValue, alist.lookupAL in *;
  destruct_all_eq_dec;
  simplify_const2GV;
  simplify_instantiate_gvs_singleton;
  simplify_getTypeAllocSize;

  match goal with
     | [ H : context [id] |- _ ] => cbv delta [id] in H; simpl in H; rename H into Hnew
  end;
  simpl in *;

  injection_Some_eq_Some;
  subst;
  simplify_instantiate_gvs_singleton;
  simpl in *.

Ltac simplify_alloca H := simplify_memory_op genericvalues.LLVMgv.malloc H.
Ltac simplify_load H := simplify_memory_op genericvalues.LLVMgv.mload H; try destruct_match_Some.
Ltac simplify_store H := simplify_memory_op genericvalues.LLVMgv.mstore H; try destruct_match_Some.

Lemma lift_op1_simplified :
  forall op v t x y a b c,
    eq y [(Values.Vint a b, c)] ->
    (ndopsem.MNDGVs.lift_op1 op
                             (Ensembles.Singleton genericvalues.LLVMgv.GenericValue v)
                             t = Some x ->
     op v = Some y ->
     eq (Ensembles.Singleton genericvalues.LLVMgv.GenericValue y) x).
Proof.
  intros op v t x y a b c H H0 H1.
  unfold ndopsem.MNDGVs.lift_op1 in H0.
  unfold ndopsem.MNDGVs.instantiate_gvs in H0.
  unfold ndopsem.MNDGVs.gv2gvs in H0.
  injection H0; clear H0; intro H0.
  subst x.
  extensionality z.
  apply Axioms.prop_ext.
  split.
  intro.
  repeat eexists.
  apply H1.
  rewrite H.
  rewrite <- H.
  unfold Ensembles.In.
  assumption.
  intro.
  decompose [ex and] H0; clear H0.
  destruct H2.
  rewrite H1 in H3.
  injection H3; clear H3; intro H3.
  subst x0.
  subst y.
  assumption.
Qed.

Ltac simplify_lifted_op_1 :=
  simplify;
  match goal with
    | [ H : eq (ndopsem.MNDGVs.lift_op1 _ _ _) _ |- _ ] =>
      eapply lift_op1_simplified in H; [
        | reflexivity
        | compute; reflexivity ]
  end;
  subst.

Lemma lift_op2_simplified :
  forall op v1 v2 t x y a b c,
    eq y [(Values.Vint a b, c)] ->
    (ndopsem.MNDGVs.lift_op2 op
                             (Ensembles.Singleton genericvalues.LLVMgv.GenericValue v1)
                             (Ensembles.Singleton genericvalues.LLVMgv.GenericValue v2)
                             t = Some x ->
     op v1 v2 = Some y ->
     eq (Ensembles.Singleton genericvalues.LLVMgv.GenericValue y) x).
Proof.
  intros op v1 v2 t x y a b c H H0 H1.
  unfold ndopsem.MNDGVs.lift_op2 in H0.
  unfold ndopsem.MNDGVs.instantiate_gvs in H0.
  unfold ndopsem.MNDGVs.gv2gvs in H0.
  injection H0; clear H0; intro H0.
  subst x.
  extensionality z.
  apply Axioms.prop_ext.
  split.
  intro.
  repeat eexists.
  apply H1.
  rewrite H.
  rewrite <- H.
  unfold Ensembles.In.
  assumption.
  intro.
  decompose [ex and] H0; clear H0.
  destruct H2.
  destruct H3.
  rewrite H1 in H4.
  injection H4; clear H4; intro H4.
  subst x1.
  subst y.
  assumption.
Qed.

Ltac simplify_lifted_op_2 :=
  simplify;
  match goal with
    | [ H : eq (ndopsem.MNDGVs.lift_op2 _ _ _ _) _ |- _ ] =>
      eapply lift_op2_simplified in H; [
        | reflexivity
        | compute; reflexivity ]
  end;
  subst.

Ltac simplify_bop := simplify_lifted_op_2.
Ltac simplify_trunc := simplify_lifted_op_1.
Ltac simplify_ext := simplify_lifted_op_1.
Ltac simplify_icmp := simplify_lifted_op_2.

Ltac simplify_select :=
  unfold getOperandValue, alist.lookupAL in *;
  destruct_all_eq_dec;
  injection_Some_eq_Some;
  subst;
  simplify_instantiate_gvs_singleton;
  simpl in *;
  destruct_all_eq_dec;
  repeat match goal with
           | [ H : eq (const2GV _ _ _) (Some _) |- _ ] =>
             compute in H;
             injection H; clear H; intro H; subst
         end.

Ltac simplify_br_uncond :=
  match goal with
    | [ H1 : eq _ (lookupBlockViaLabelFromFdef _ _),
        H2 : eq (switchToNewBasicBlock _ _ _ _ _) _ |- _ ] =>
      unfold lookupBlockViaLabelFromFdef in H1;
      simpl in H1;
      simplify;
      injection H1; clear H1; intros; subst;
      unfold switchToNewBasicBlock in H2;
      simpl in H2;
      injection_Some_eq_Some;
      subst
  end.

Ltac simplify_br :=
  match goal with
    | [ H1 : eq _ (if isGVZero _ _ then _ else _),
        H2 : eq (switchToNewBasicBlock _ _ _ _ _) _ |- _ ] =>
      unfold getOperandValue, alist.lookupAL in *;
      destruct_all_eq_dec;
      injection_Some_eq_Some;
      subst;
      simplify_instantiate_gvs_singleton;
      simpl in *;
      destruct_all_eq_dec;
      injection H1; clear H1; intros; subst;
      unfold switchToNewBasicBlock in H2;
      simpl in H2;
      injection_Some_eq_Some;
      subst
  end.

Ltac simplify_ret :=
  unfold getOperandValue, alist.lookupAL in *;
  destruct_all_eq_dec;
  injection_Some_eq_Some;
  subst;
  simplify_const2GV;
  simplify_instantiate_gvs_singleton.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-require" "coqharness" "-impredicative-set" "-R" "." "Tvc" "-R" "../../csem/_coq" "Csem" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/ott" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/monads" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/compcert" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/GraphBasics" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/Dominators" "-I" "../../vellvm-coq84pl2/release/vol/extralibs/metatheory_8.4" "-I" "../../vellvm-coq84pl2/release/vol/extralibs/Coq-Equations/src" "-R" "../../vellvm-coq84pl2/release/vol/extralibs/Coq-Equations/theories" "Equations" "-I" "~/lem/coq-lib") ***
*** End: ***
*)