Require Import Coq.Logic.FunctionalExtensionality.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.AbsAppI.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprD.
Require Import MirrorCore.Lambda.ExprDFacts.
Require Import MirrorCore.Lambda.Red.

Set Implicit Arguments.
Set Strict Implicit.

Section some_lemmas.
  Variable typ : Set.
  Variable sym : Set.
  Variable RType_typ : RType typ.
  Variable RTypeOk : RTypeOk.
  Variable Typ2_arr : Typ2 _ RFun.
  Variable Typ2Ok_arr : Typ2Ok Typ2_arr.
  Variable RSym_sym : RSym sym.
  Variable RSymOk_sym : RSymOk RSym_sym.

  Lemma lambda_exprD_typeof_not_None
  : forall tus tvs (e : expr typ sym) (t : typ) val,
      lambda_exprD tus tvs t e = Some val ->
      typeof_expr tus tvs e <> None.
  Proof.
    intros.
    generalize (lambda_exprD_typeof_expr _ (or_introl H)).
    congruence.
  Qed.

  Lemma lambda_exprD_typeof_Some
  : forall tus tvs e t val,
      lambda_exprD tus tvs t e = Some val ->
      typeof_expr tus tvs e = Some t.
  Proof.
    intros.
    generalize (lambda_exprD_typeof_expr _ (or_introl H)).
    congruence.
  Qed.

  Lemma lambda_exprD_typeof_eq
  : forall tus tvs e t t' val,
      lambda_exprD tus tvs t e = Some val ->
      typeof_expr tus tvs e = Some t' ->
      t = t'.
  Proof.
    intros.
    generalize (lambda_exprD_typeof_expr _ (or_introl H)).
    congruence.
  Qed.

  Global Instance Injective_typ2 {F : Type -> Type -> Type}
         {Typ2_F : Typ2 RType_typ F} {Typ2Ok_F : Typ2Ok Typ2_F} a b c d :
    Injective (typ2 a b = typ2 c d) :=
  { result := a = c /\ b = d }.
  abstract (
      eapply typ2_inj; eauto ).
  Defined.

  Global Instance Injective_typ1 {F : Type -> Type}
         {Typ1_F : Typ1 RType_typ F} {Typ2Ok_F : Typ1Ok Typ1_F} a b
  : Injective (typ1 a = typ1 b) :=
  { result := a = b }.
  abstract (
      eapply typ1_inj; eauto ).
  Defined.

  Lemma lambda_exprD_AppI tus tvs (t : typ) (e1 e2 : expr typ sym)
        (P : option (exprT tus tvs (typD t)) -> Prop)
        (H : exists u v1 v2, lambda_exprD tus tvs (typ2 u t) e1 = Some v1 /\
                             lambda_exprD tus tvs u e2 = Some v2 /\
                             P (Some (exprT_App v1 v2))) :
    P (lambda_exprD tus tvs t (App e1 e2)).
  Proof.
    autorewrite with exprD_rw; simpl.
    destruct H as [u [v1 [v2 [H1 [H2 HP]]]]].
    pose proof (lambda_exprD_typeof_Some _ _ H1).
    pose proof (lambda_exprD_typeof_Some _ _ H2).
    repeat (forward; inv_all; subst).
  Qed.

  Lemma lambda_exprD_InjI tus tvs (t : typ) (f : sym)
        (P : option (exprT tus tvs (typD t)) -> Prop)
        (H : exists v, symAs f t = Some v /\ P (Some (fun _ _ => v))) :
    P (lambda_exprD tus tvs t (Inj f)).
  Proof.
    autorewrite with exprD_rw; simpl.
    destruct (symAs f t); simpl; destruct H as [v [H1 H2]]; try intuition congruence.
    inv_all; subst. apply H2.
  Qed.

  Lemma lambda_exprD_beta tus tvs e t P
        (H : exists v, lambda_exprD tus tvs t e = Some v /\ P (Some v)) :
    P (lambda_exprD tus tvs t (beta e)).
  Proof.
    destruct H as [v [H1 H2]].
    pose proof (beta_sound tus tvs e t).
    forward; inv_all; subst.
    assert (v = e1).
    do 2 (apply functional_extensionality; intro).
    apply H3. subst. apply H2.
  Qed.

  Global Instance Injective_lambda_exprD_App tus tvs (e1 e2 : expr typ sym) (t : typ)
         (v : exprT tus tvs (typD t)):
    Injective (ExprDsimul.ExprDenote.lambda_exprD tus tvs t (App e1 e2) = Some v) := {
      result := exists u v1 v2, ExprDsimul.ExprDenote.lambda_exprD tus tvs (typ2 u t) e1 = Some v1 /\
                                ExprDsimul.ExprDenote.lambda_exprD tus tvs u e2 = Some v2 /\
                                v = exprT_App v1 v2;
      injection := fun H => _
    }.
  Proof.
    autorewrite with exprD_rw in H.
    simpl in H. forward; inv_all; subst.
    do 3 eexists; repeat split; eassumption.
  Defined.

  Global Instance Injective_lambda_exprD_Inj tus tvs (f : sym) (t : typ) (v : exprT tus tvs (typD t)):
    Injective (ExprDsimul.ExprDenote.lambda_exprD tus tvs t (Inj f) = Some v) := {
      result := exists v', symAs f t = Some v' /\ v = exprT_Inj _ _ v';
      injection := fun H => _
    }.
  Proof.
    autorewrite with exprD_rw in H.
    simpl in H. forward; inv_all; subst.
    eexists; repeat split.
  Defined.

  Lemma lambda_exprD_AppL : forall tus tvs tx ty f x fD,
      lambda_exprD tus tvs (typ2 (F:=RFun) tx ty) f = Some fD ->
      lambda_exprD tus tvs ty (App f x) =
      match lambda_exprD tus tvs tx x with
      | None => None
      | Some xD => Some (AbsAppI.exprT_App fD xD)
      end.
  Proof.
    simpl; intros.
    rewrite lambda_exprD_App.
    destruct (lambda_exprD tus tvs tx x) eqn:?.
    { erewrite lambda_exprD_typeof_Some by eassumption.
      rewrite H. rewrite Heqo. reflexivity. }
    { destruct (typeof_expr tus tvs x) eqn:?; auto.
      destruct (lambda_exprD tus tvs (typ2 t ty) f) eqn:?; auto.
      assert (t = tx).
      { destruct (ExprFacts.lambda_exprD_single_type H Heqo1).
        clear H0. eapply typ2_inj in x0; eauto.
        destruct x0. symmetry. apply H0. }
      { subst. rewrite Heqo. reflexivity. } }
  Qed.

  Lemma lambda_exprD_AppR : forall tus tvs tx ty f x xD,
      lambda_exprD tus tvs tx x = Some xD ->
      lambda_exprD tus tvs ty (App f x) =
      match lambda_exprD tus tvs (typ2 tx ty) f with
      | None => None
      | Some fD => Some (AbsAppI.exprT_App fD xD)
      end.
  Proof.
    simpl; intros.
    rewrite lambda_exprD_App.
    erewrite lambda_exprD_typeof_Some by eassumption.
    rewrite H.
    reflexivity.
  Qed.

  Lemma lambda_exprD_App_both_cases : forall tus tvs tx ty f x fD xD,
      lambda_exprD tus tvs (typ2 (F:=RFun) tx ty) f = Some fD ->
      lambda_exprD tus tvs tx x = Some xD ->
      lambda_exprD tus tvs ty (App f x) = Some (AbsAppI.exprT_App fD xD).
  Proof.
    intros. erewrite lambda_exprD_AppR by eassumption.
    rewrite H. reflexivity.
  Qed.

  Lemma lambda_exprD_App
    : forall tus tvs td tr f x fD xD,
      lambda_exprD tus tvs (typ2 (F:=RFun) td tr) f = Some fD ->
      lambda_exprD tus tvs td x = Some xD ->
      lambda_exprD tus tvs tr (App f x) = Some (AbsAppI.exprT_App fD xD).
  Proof using Typ2Ok_arr RSymOk_sym RTypeOk.
    intros.
    autorewrite with exprD_rw; simpl.
    erewrite lambda_exprD_typeof_Some by eauto.
    rewrite H. rewrite H0. reflexivity.
  Qed.

  Lemma lambda_exprD_Abs_prem
    : forall tus tvs t t' x xD,
      ExprDsimul.ExprDenote.lambda_exprD tus tvs t (Abs t' x) = Some xD ->
      exists t'' (pf : typ2 t' t'' = t) bD,
        ExprDsimul.ExprDenote.lambda_exprD tus (t' :: tvs) t'' x = Some bD /\
        xD = match pf with
             | eq_refl => AbsAppI.exprT_Abs bD
             end.
  Proof using Typ2Ok_arr RSymOk_sym RTypeOk.
    intros.
    autorewrite with exprD_rw in H.
    destruct (typ2_match_case t); forward_reason.
    { rewrite H0 in H; clear H0.
      red in x2; subst. simpl in *.
      autorewrite_with_eq_rw_in H.
      destruct (type_cast x0 t'); subst; try congruence.
      red in r; subst.
      forward. inv_all; subst.
      eexists; exists eq_refl.
      eexists; split; eauto. inversion H.
      unfold AbsAppI.exprT_Abs.
      autorewrite_with_eq_rw.
      reflexivity. }
    { rewrite H0 in H. congruence. }
  Qed.

End some_lemmas.

Hint Rewrite lambda_exprD_App_both_cases using eassumption : exprD_rw.
Hint Rewrite lambda_exprD_AppL using eassumption : exprD_rw.
Hint Rewrite lambda_exprD_AppR using eassumption : exprD_rw.

Ltac red_exprD :=
  autorewrite with exprD_rw; simpl. (** TODO: this should be restricted **)

Ltac forward_exprD :=
  repeat match goal with
           | H : _ = _ , H' : _ = _ |- _ =>
             let x := constr:(@lambda_exprD_typeof_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ H H') in
             match type of x with
               | ?X = ?X => fail 1
               | _ => specialize x ; intro ; try inv_all ; try subst
             end
           | H : lambda_exprD _ _ ?T ?X = _ , H' : lambda_exprD _ _ ?T' ?X = _ |- _ =>
             match T with
               | T' => fail 1
               | _ =>
                 generalize (@lambda_exprD_deterministic _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H H');
                   let X := fresh in intro X; red in X;
                   try inv_all; try subst
             end
         end.

Ltac arrow_case t :=
  let H := fresh in
  destruct (@typ2_match_case _ _ _ _ _ t) as [ [ ? [ ? [ ? H ] ] ] | H ];
    ( try rewrite H in * ).

Ltac arrow_case_any :=
  match goal with
    | H : context [ @typ2_match _ _ _ _ _ ?X ] |- _ =>
      arrow_case X
  end.

Section lemmas.
  Variable typ : Set.
  Variable RType_typ : RType typ.
  Variable RTypeOk : RTypeOk.

  Theorem Relim_const
  : forall T a b (pf : Rty a b),
      Relim (fun _ => T) pf = fun x => x.
  Proof.
    clear. destruct pf. reflexivity.
  Qed.

  Lemma type_cast_sym_Some
  : forall a b pf,
      type_cast a b = Some pf ->
      type_cast b a = Some (Rsym pf).
  Proof.
    intros. destruct pf.
    rewrite type_cast_refl; eauto.
  Qed.

  Lemma type_cast_sym_None
  : forall a b,
      type_cast a b = None ->
      type_cast b a = None.
  Proof.
    intros.
    destruct (type_cast b a); auto.
    destruct r.
    rewrite type_cast_refl in H; eauto.
  Qed.
End lemmas.

(** TODO: This needs to move *)
Section thing.
  Variable typ : Set.
  Variable RType_typ : RType typ.
  Variable RTypeOk_typ : RTypeOk.
  Variable F : Type@{Urefl} -> Type@{Urefl} -> Type@{Urefl}.
  Variable Typ2_F : Typ2 _ F.
  Variable Typ2Ok_F : Typ2Ok Typ2_F.

  Definition typ2_Rty (a b c d : typ) (pf : Rty a b) (pf' : Rty c d)
  : Rty (typ2 a c) (typ2 b d) :=
    match pf , pf' with
    | eq_refl , eq_refl => eq_refl
    end.

  Lemma decompose_Rty_typ2 : forall {a b c d : typ} (pf : Rty (typ2  a b) (typ2 c d)),
      exists pf' pf'', pf = typ2_Rty pf' pf''.
  Proof.
    intros. generalize pf.
    intros. inv_all.
    subst. exists eq_refl. exists eq_refl. simpl.
    apply UIP_refl.
  Defined.

  Lemma symAs_D :
    forall (Typ2_Fun : Typ2 RType_typ RFun)
      (func : Set) (RSym_func : RSym func),
      forall (f : func) (t : typ) (v : typD t),
        symAs f t = Some v ->
        match typeof_sym f as X return match X with
                                       | None => unit
                                       | Some t => typD t
                                       end -> Prop with
        | None => fun _ => False
        | Some t' => fun d =>
                      exists pf : Rty t' t,
                        Rcast_val pf d = v
        end (symD f).
  Proof.
    clear. intros.
    unfold symAs in H.
    generalize dependent (symD f).
    destruct (typeof_sym f).
    { intros. destruct (type_cast t t0).
      { exists (Rsym r). inv_all. unfold Rcast_val, Rcast, Relim in *.
        unfold Rsym. rewrite eq_sym_involutive. assumption. }
      { exfalso. clear - H. discriminate H. } }
    { clear. intros. discriminate H. }
  Defined.

  Lemma Rcast_val_eq_refl : forall a pf x, @Rcast_val _ _ a a pf x = x.
  Proof.
    intros. rewrite (UIP_refl pf). reflexivity.
  Defined.

End thing.

Ltac lambda_exprD_fwd :=
  repeat match goal with
         | H : symAs _ _ = Some _ |- _ =>
           (eapply symAs_D in H; eauto); [] ; simpl in H; destruct H
         | pf : Rty _ _ |- _ =>
           destruct (decompose_Rty_typ2 _ _ pf) as [ ? [ ? ? ] ] ; subst pf
         | pf : lambda_exprD _ _ _ (Abs _ _) = Some _ |- _ =>
           apply lambda_exprD_Abs_prem in pf ; eauto ; [ ] ; destruct pf as [ ? [ ? [ ? [ ? ? ] ] ] ]
         | pf : Rty _ ?X |- _ => is_var X ; destruct pf
         | pf : Rty ?X _ |- _ => is_var X ; red in pf ; subst X
         | |- _ => progress inv_all ; subst
         end.

Require Import MirrorCore.ExprI.
Section exprT.
  Context {typ : Set}.
  Context {RType_typ : RType typ}.
  (** TODO(gmalecha): These should go somewhere else since they are generic
   ** to exprT.
   **)
  Lemma exprT_Inj_castR
  : forall (tus tvs : tenv typ) (T : Type@{Urefl}) (Ty0 : Typ0 _ T) (v : T),
    @exprT_Inj _ _ _ _ (typD _) (castR (@id Type@{Urefl}) T v) = castR (exprT tus tvs) _ (exprT_Inj _ _ v).
  Proof.
    clear. unfold exprT_Inj, castR. intros.
    generalize dependent (typ0_cast (F:=T)).
    intro e. generalize dependent (typD (typ0 (F:=T))).
    intros; subst. reflexivity.
  Defined.

  Theorem exprT_App_castRl
    : forall (tus tvs : tenv typ) (T U : Type@{Urefl})
        (Ty2 : Typ2 _ RFun) (Ty0T : Typ0 _ T) (Ty0U : Typ0 _ U)
        e1 e2,
      AbsAppI.exprT_App (castR (exprT tus tvs) (RFun T U) e1) e2 =
      castR (exprT tus tvs) U (Applicative.ap e1 (castD (exprT tus tvs) T e2)).
  Proof.
    unfold AbsAppI.exprT_App, castR, castD. simpl; intros.
    generalize dependent (typ0_cast (F:=U)).
    generalize dependent (typ0_cast (F:=T)).
    generalize dependent (typ2_cast (typ0 (F:=T)) (typ0 (F:=U))).
    clear.
    intros.
    generalize dependent (typD (typ0 (F:=T))).
    generalize dependent (typD (typ0 (F:=U))).
    intros; subst. simpl.
    generalize dependent (typD (typ2 (typ0 (F:=T)) (typ0 (F:=U)))).
    intros; subst. reflexivity.
  Defined.
End exprT.

Ltac simpl_exprT :=
  repeat match goal with
         | |- context [ (fun a b => ?F a b) ] =>
           change (fun a b => F a b) with F
         | |- _ => rewrite castDR
         | |- _ => rewrite castRD
         | |- context [ exprT_Inj ?tus ?tvs (@castR _ _ _ _ ?T ?v) ] =>
           let H := fresh in
           pose proof (@exprT_Inj_castR _ _ tus tvs _ T v) as H ; change_rewrite H ; clear H
         | |- context [ @AbsAppI.exprT_App _ _ _ ?tus ?tvs ?d ?c (@castR _ _ _ ?T _ ?f) ?x] =>
           let H := fresh in
           pose proof (@exprT_App_castRl _ _ tus tvs _ _ _ _ _ f x) as H ; change_rewrite H ; clear H
         end.

(* TODO(gmalecha): Remove this. It appears to be duplicated.
Section ExprDInject.
  Context {typ func : Set}.
  Context {RType_typ : RType typ} {RTypeOk_typ : RTypeOk}.
  Context {RSym_func : RSym func} {RSymOk_func : RSymOk RSym_func}.
  Context {Typ2_tyArr : Typ2 _ RFun} {Typ2Ok_tyArr : Typ2Ok Typ2_tyArr}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ Typ2_tyArr.

  Global Instance Injective_lambda_exprD_App tus tvs (e1 e2 : expr typ func) (t : typ)
         (v : exprT tus tvs (typD t)):
    Injective (ExprDsimul.ExprDenote.lambda_exprD tus tvs t (App e1 e2) = Some v) := {
      result := exists u v1 v2, ExprDsimul.ExprDenote.lambda_exprD tus tvs (tyArr u t) e1 = Some v1 /\
                                ExprDsimul.ExprDenote.lambda_exprD tus tvs u e2 = Some v2 /\
                                v = AbsAppI.exprT_App v1 v2;
      injection := fun H => _
    }.
  Proof.
    autorewrite with exprD_rw in H.
    simpl in H. forward; inv_all; subst.
    do 3 eexists; repeat split; eassumption.
  Defined.

  Global Instance Injective_lambda_exprD_Inj tus tvs (f : func) (t : typ) (v : exprT tus tvs (typD t)):
    Injective (ExprDsimul.ExprDenote.lambda_exprD tus tvs t (Inj f) = Some v) := {
      result := exists v', symAs f t = Some v' /\ v = exprT_Inj _ _ v' ;
      injection := fun H => _
    }.
  Proof.
    autorewrite with exprD_rw in H.
    simpl in H. forward; inv_all; subst.
    eexists; repeat split.
  Defined.

End ExprDInject.
*)


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section RefineRel.

  Record relate_RData (hadt: RData) (ladt: RData) :=
    mkrelate_RData {
            id_rdata: hadt = ladt
        }.

End RefineRel.


Require Import Utils.
Require Import Maps.
Require Import PropertyGraph.
Require Import Cypher.
Require Import BindingTable.
Require Import Semantics.
Require Import PatternE.

Import PartialMap.Notations.
Import PropertyGraph.

Module FilterMode.
  Inductive t : Type :=
  | Vertices
  | Edges
  .
End FilterMode.

Module ExpandMode .
  Inductive t : Type :=
  | All
  | Into
  .
End ExpandMode.

(* r' is expanded from r by traversing one edge *)
Definition expansion_of' (g : PropertyGraph.t) (r' r : Rcd.t)
                         (mode : ExpandMode.t)
                         (v_from : vertex) (e : edge) (v_to : vertex)
                         (n_from n_edge n_to : Name.t)
                         (d : Pattern.direction) :=
  << HIn_e : In e (edges g) >> /\
  << Hdir : Path.matches_direction g v_from v_to e d >> /\
  << Hval_from : r n_from = Some (Value.GVertex v_from) >> /\
  << Hval_edge : r n_edge = None >> /\
  << Hval' : r' = (n_to |-> Value.GVertex v_to; n_edge |-> Value.GEdge e; r) >> /\
  match mode with
  | ExpandMode.All =>
    << Hval_to : r n_to = None >>
  | ExpandMode.Into =>
    << Hval_to : r n_to = Some (Value.GVertex v_to) >>
  end.

(* r' is expanded from r by traversing one edge *)
Definition expansion_of (g : PropertyGraph.t) (r' r : Rcd.t)
                        (mode : ExpandMode.t)
                        (n_from n_edge n_to : Name.t)
                        (d : Pattern.direction) :=
  exists v_from e v_to,
    expansion_of' g r' r mode v_from e v_to n_from n_edge n_to d.

Import FilterMode.
Import ExpandMode.

Module ExecutionPlan.
  Definition step0 := PropertyGraph.t -> option BindingTable.t.
  Definition step1 := PropertyGraph.t -> BindingTable.t -> option BindingTable.t.

  Module Type Spec.
    (* scan_vertices (n : Name.t) : step0 *)
    Parameter scan_vertices : Name.t -> step0.

    (* filter_by_label (mode : FilterMode.t) (n : Name.t) (l : label) : step1 *)
    Parameter filter_by_label : FilterMode.t -> Name.t -> label -> step1.

    (* expand (mode : ExpandMode.t) (n_from n_edge n_to : Name.t) (d : Pattern.direction) : step1 *)
    Parameter expand : ExpandMode.t -> Name.t -> Name.t -> Name.t -> Pattern.direction -> step1.

    (* return_all : step1 *)
    Parameter return_all : step1.

    (* traverse (slice : PatternSlice.t) (n_from : Name.t) : step1 *)
    Parameter traverse : PatternSlice.t -> Name.t -> step1.

    Section axioms.
      Variable graph : PropertyGraph.t.
      Variable table : BindingTable.t.
      Variable table' : BindingTable.t.
      Variable ty : BindingTable.T.

      (** If the inputs are well-formed then the operation will return the result *)

      Axiom scan_vertices_wf : forall n,
        PropertyGraph.wf graph ->
          exists table', scan_vertices n graph = Some table'.

      Axiom filter_vertices_by_label_wf : forall n l,
        PropertyGraph.wf graph -> BindingTable.of_type table ty ->
          ty n = Some Value.GVertexT ->
            exists table', filter_by_label Vertices n l graph table = Some table'.

      Axiom filter_edges_by_label_wf : forall n l,
        PropertyGraph.wf graph -> BindingTable.of_type table ty ->
          ty n = Some Value.GEdgeT ->
            exists table', filter_by_label Edges n l graph table = Some table'.

      Axiom expand_all_wf : forall n_from n_edge n_to d,
        PropertyGraph.wf graph -> BindingTable.of_type table ty ->
          ty n_from = Some Value.GVertexT -> ty n_edge = None -> ty n_to = None ->
              exists table', expand All n_from n_edge n_to d graph table = Some table'.

      Axiom expand_into_wf : forall n_from n_edge n_to d,
        PropertyGraph.wf graph -> BindingTable.of_type table ty ->
          ty n_from = Some Value.GVertexT -> ty n_edge = None -> ty n_to = Some Value.GVertexT ->
            exists table', expand Into n_from n_edge n_to d graph table = Some table'.

      Axiom return_all_wf :
        exists table', return_all graph table = Some table'.

      Axiom traverse_wf : forall slice n_from,
        PropertyGraph.wf graph -> BindingTable.of_type table ty ->
          PatternSlice.wf ty slice -> ty n_from = Some Value.GVertexT ->
            exists table', traverse slice n_from graph table = Some table'.

      (** If the operation returned some table then the type of the table is correct *)

      Axiom scan_vertices_type : forall n,
        scan_vertices n graph = Some table' ->
          BindingTable.of_type table' (n |-> Value.GVertexT).

      Axiom filter_by_label_type : forall mode n l,
        filter_by_label mode n l graph table = Some table' ->
          BindingTable.of_type table ty ->
            BindingTable.of_type table' ty.

      Axiom expand_type : forall mode n_from n_edge n_to d,
        expand mode n_from n_edge n_to d graph table = Some table' ->
          BindingTable.of_type table ty ->
            BindingTable.of_type table'
              (n_to |-> Value.GVertexT; n_edge |-> Value.GEdgeT; ty).

      Axiom return_all_type :
        return_all graph table = Some table' ->
          BindingTable.of_type table ty ->
            BindingTable.of_type table' (Rcd.explicit_projT ty).

      Axiom traverse_type : forall slice n_from,
        traverse slice n_from graph table = Some table' ->
          BindingTable.of_type table ty ->
            BindingTable.of_type table' (PatternSlice.type_of ty slice).

      (** scan_vertices specification *)

      Axiom scan_vertices_spec : forall n v,
        scan_vertices n graph = Some table' ->
          In v (vertices graph) ->
            In (n |-> Value.GVertex v) table'.

      Axiom scan_vertices_spec' : forall n r',
        scan_vertices n graph = Some table' ->
          In r' table' -> exists v,
            r' = (n |-> Value.GVertex v) /\ In v (vertices graph).

      (** filter_by_label specification *)

      Axiom filter_vertices_by_label_spec : forall n l v r,
        filter_by_label Vertices n l graph table = Some table' ->
          r n = Some (Value.GVertex v) -> In l (vlabels graph v) ->
            In r table -> In r table'.

      Axiom filter_vertices_by_label_spec' : forall n l r',
        filter_by_label Vertices n l graph table = Some table' ->
           In r' table' -> In r' table /\
            exists v, r' n = Some (Value.GVertex v) /\ In l (vlabels graph v).

      Axiom filter_edges_by_label_spec : forall n l e r,
        filter_by_label Edges n l graph table = Some table' ->
          r n = Some (Value.GEdge e) -> elabel graph e = l ->
            In r table -> In r table'.

      Axiom filter_edges_by_label_spec' : forall n l r',
        filter_by_label Edges n l graph table = Some table' ->
          In r' table' -> In r' table /\
            exists e, r' n = Some (Value.GEdge e) /\ elabel graph e = l.

      (** expand specification *)

      Axiom expand_spec : forall r r' mode n_from n_edge n_to d,
        expand mode n_from n_edge n_to d graph table = Some table' ->
          expansion_of graph r' r mode n_from n_edge n_to d ->
            In r table -> In r' table'.

      Axiom expand_spec' : forall r' mode n_from n_edge n_to d,
        expand mode n_from n_edge n_to d graph table = Some table' -> In r' table' ->
            exists r, In r table /\ expansion_of graph r' r mode n_from n_edge n_to d.

      (** return_all specification *)

      Axiom return_all_spec : forall r,
        return_all graph table = Some table' ->
          In r table -> In (Rcd.explicit_proj r) table'.

      Axiom return_all_spec' : forall r',
        return_all graph table = Some table' ->
          In r' table' -> exists r, In r table /\ r' = Rcd.explicit_proj r.

      (** traverse specification *)

      Axiom traverse_spec : forall path r r' slice n_from,
        traverse slice n_from graph table = Some table' ->
          PathSlice.matches graph r n_from r' path slice ->
            In r table -> In r' table'.

      Axiom traverse_spec' : forall r' slice n_from,
        traverse slice n_from graph table = Some table' ->
          In r' table' -> exists r path, In r table /\
            PathSlice.matches graph r n_from r' path slice.
    End axioms.
  End Spec.

  Inductive t :=
  | ScanVertices (n : Name.t)
  | FilterByLabel (mode : FilterMode.t) (n : Name.t) (l : label) (plan : t)
  | Expand (mode : ExpandMode.t) (n_from n_edge n_to : Name.t) (d : Pattern.direction) (plan : t)
  | ReturnAll (plan : t)
  | Traverse (slice : PatternSlice.t) (n_from : Name.t) (plan : t)
  .

  Fixpoint type_of (plan : t) : BindingTable.T :=
    match plan with
    | ScanVertices n => n |-> Value.GVertexT
    | FilterByLabel mode n l plan => type_of plan
    | Expand mode n_from n_edge n_to d plan => n_to |-> Value.GVertexT; n_edge |-> Value.GEdgeT; type_of plan
    | ReturnAll plan => Rcd.explicit_projT (type_of plan)
    | Traverse slice n_from plan => PatternSlice.type_of (type_of plan) slice
    end.

  Lemma type_of_types plan k :
    type_of plan k = Some Value.GVertexT \/
    type_of plan k = Some Value.GEdgeT \/
    type_of plan k = None.
  Proof using.
    induction plan; simpl in *.
    all: unfold Rcd.explicit_projT.
    all: autounfold with unfold_pat.
    all: desf.
    all: auto using PatternSlice.type_of__types.
  Qed.

  Fixpoint wf (plan : t) :=
    match plan with
    | ScanVertices n => True
    | FilterByLabel Vertices n l plan =>
      << Htype : type_of plan n = Some Value.GVertexT >> /\
      << Hwf : wf plan >>
    | FilterByLabel Edges n l plan =>
      << Htype : type_of plan n = Some Value.GEdgeT >> /\
      << Hwf : wf plan >>
    | Expand All n_from n_edge n_to d plan =>
      << Htype_from : type_of plan n_from = Some Value.GVertexT >> /\
      << Htype_edge : type_of plan n_edge = None >> /\
      << Htype_to : type_of plan n_to = None >> /\
      << Hneq_from : n_from =/= n_edge >> /\
      << Hneq_to : n_to =/= n_edge >> /\
      << Hwf : wf plan >>
    | Expand Into n_from n_edge n_to d plan =>
      << Htype_from : type_of plan n_from = Some Value.GVertexT >> /\
      << Htype_edge : type_of plan n_edge = None >> /\
      << Htype_to : type_of plan n_to = Some Value.GVertexT >> /\
      << Hneq_from : n_from =/= n_edge >> /\
      << Hneq_to : n_to =/= n_edge >> /\
      << Hwf : wf plan >>
    | ReturnAll plan =>
      << Hwf : wf plan >>
    | Traverse slice n_from plan =>
      << Htype : type_of plan n_from = Some Value.GVertexT >> /\
      << Hwf_slice : PatternSlice.wf (type_of plan) slice >> /\
      << Hwf : wf plan >>
    end.

  Module EvalPlan (S : Spec).
    Import S.

    #[local]
    Hint Resolve scan_vertices_type filter_by_label_type
                expand_type return_all_type traverse_type : type_axioms.

    #[local]
    Hint Resolve scan_vertices_wf filter_vertices_by_label_wf filter_edges_by_label_wf
                 expand_all_wf expand_into_wf return_all_wf traverse_wf : wf_axioms.

    Section eval.
      Variable graph : PropertyGraph.t.
      Fixpoint eval (plan : ExecutionPlan.t) :=
        match plan with
        | ScanVertices n => scan_vertices n graph
        | FilterByLabel mode n l plan =>
          eval plan >>= filter_by_label mode n l graph
        | Expand mode n_from n_edge n_to d plan =>
          eval plan >>= expand mode n_from n_edge n_to d graph
        | ReturnAll plan => eval plan >>= return_all graph
        | Traverse slice n_from plan =>
          eval plan >>= traverse slice n_from graph
        end.
    End eval.

    Theorem eval_type_of plan graph table'
                         (Heval : eval graph plan = Some table') :
        BindingTable.of_type table' (type_of plan).
    Proof using.
      generalize dependent table'.
      induction plan; intros; simpl in *.
      { apply scan_vertices_type with graph. assumption. }
      all: destruct (eval graph plan); try discriminate.

      2: destruct mode.
      all: eauto with type_axioms.
    Qed.

    Theorem eval_wf plan graph (Hwf : wf plan) (Hwf' : PropertyGraph.wf graph) :
        exists table', eval graph plan = Some table'.
    Proof with (try eassumption).
      induction plan. all: simpl in *; desf; desf.
      { apply scan_vertices_wf... }
      all: destruct IHplan as [table IH]...
      all: rewrite IH; simpl.
      all: eauto using eval_type_of with wf_axioms.
    Qed.
  End EvalPlan.
End ExecutionPlan.


Require Import
        Coq.Vectors.Vector
        Coq.ZArith.ZArith
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Bool.Bool
        Coq.Vectors.Vector
        Coq.Lists.List.

Require Import
        Fiat.Common.BoundedLookup
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Narcissus.Formats.DomainNameOpt
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple.

Require Import
        Bedrock.Word
        Bedrock.Memory.

Import Lists.List.ListNotations.
Import Vectors.Vector.VectorNotations.

Local Open Scope string_scope.
Local Open Scope Tuple_scope.
Local Open Scope vector_scope.

Require Export Fiat.Narcissus.Examples.DNS.RRecordTypes.

Section QTypes.

  (* DNS packet Query Types are a superset of RR Types. *)
  Definition QTypes :=
    ["TKEY"; (* Transaction Key 	[RFC2930] *)
     "TSIG"; (* Transaction Signature 	[RFC2845] *)
     "IXFR"; (* incremental transfer 	[RFC1995] *)
     "AXFR"; (* transfer of an entire zone 	[RFC1035][RFC5936] *)
     "MAILB"; (* mailbox-related RRs (MB, MG or MR) 	[RFC1035] *)
     "MAILA"; (* mail agent RRs (OBSOLETE - see MX) 	[RFC1035] *)
     "STAR" (*A request for all records the server/cache has available 	[RFC1035][RFC6895] *)
    ].

  Definition QType_Ws : t (word 16) 17 :=
    Eval simpl in RRecordType_Ws ++ Vector.map (natToWord 16)
                             [249; (*"TKEY" *)
                                250; (*"TSIG" *)
                                251; (*"IXFR" *)
                                252; (*"AXFR" *)
                                253;(*"MAILB" *)
                                254;(*"MAILA" *)
                                255 (* "STAR" *)].

  Definition QType := EnumType ((OurRRecordTypes(* ++ ExtraRRecordTypes) *) ++ QTypes)).

  Definition QType_inj (rr : RRecordType) : QType :=
    Fin.L _ rr.

  Definition beq_QType (a b : QType) : bool :=
    fin_beq a b.

  Definition QType_dec (a b : QType) :=
    fin_eq_dec a b.

  Lemma beq_QType_sym :
    forall rrT rrT', beq_QType rrT rrT' = beq_QType rrT' rrT.
  Proof.
    intros; eapply fin_beq_sym.
  Qed.

  Coercion QType_inj : RRecordType >-> QType.

  Definition QType_match (rtype : RRecordType) (qtype : QType) :=
    qtype = ```"STAR" \/ qtype = rtype.

End QTypes.

Section RRecordClass.

  Definition RRecordClasses :=
    [ "Internet"; (* (IN) 	[RFC1035] *)
        "Chaos"; (* (CH) 	[D. Moon, "Chaosnet", A.I. Memo 628, Massachusetts Institute of Technology Artificial Intelligence Laboratory, June 1981.] *)
        "Hesiod" (* (HS) 	[Dyer, S., and F. Hsu, "Hesiod", Project Athena Technical Plan - Name Service, April 1987.] *)
    ].

  Definition RRecordClass_Ws : t (word 16) 3 :=
    Eval simpl in Vector.map (natToWord 16)
                             [1; (* "IN" *)
                                3; (* "CH" *)
                                4 (* "Hesiod" *)].

  Definition RRecordClass := EnumType RRecordClasses.

  Definition beq_RRecordClass (a b : RRecordClass) : bool
    := fin_beq a b.

  Definition RRecordClass_dec (a b : RRecordClass) :=
    fin_eq_dec a b.

  (* DNS Packet Question Classes *)
  Definition QClass := EnumType (RRecordClasses ++ ["Any"]).

  Definition QClass_Ws : t (word 16) 4 :=
    Eval simpl in Vector.append
                    RRecordClass_Ws
                    [natToWord 16 255 (* "Any"*)].

  Definition QClass_inj (qclass : RRecordClass) : QClass :=
    Fin.L _ qclass.

  Definition beq_QClass (a b : QClass) : bool
    := fin_beq a b.

  Definition QClass_dec (a b : QClass) :=
    fin_eq_dec a b.

End RRecordClass.

Section ResponseCode.

    Definition ResponseCodes :=
    ["NoError";  (* No Error [RFC1035] *)
       "FormErr";  (* Format Error [RFC1035] *)
       "ServFail"; (* Server Failure [RFC1035] *)
       "NXDomain"; (* Non-Existent  Domain 	[RFC1035] *)
       "NotImp";   (* Not Implemented [RFC1035] *)
       "Refused";  (* Query Refused [RFC1035] *)
       "YXDomain"; (* Name Exists when it should not [RFC2136][RFC6672] *)
       "YXRRSet";  (* RR Set Exists when it should not 	[RFC2136] *)
       "NXRRSet";  (* RR Set that should exist does not 	[RFC2136] *)
       "NotAuth";  (* Server Not Authoritative for zone 	[RFC2136] *)
                   (* and Not Authorized [RFC2845] *)
       "NotZone" 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition RCODE_Ws : t (word 4) 11 :=
    Eval simpl in Vector.map (natToWord 4)
    [0;  (* No Error [RFC1035] *)
     1;  (* Format Error [RFC1035] *)
     2; (* Server Failure [RFC1035] *)
     3; (* Non-Existent  Domain 	[RFC1035] *)
     4;   (* Not Implemented [RFC1035] *)
     5;  (* Query Refused [RFC1035] *)
     6; (* Name Exists when it should not [RFC2136][RFC6672] *)
     7;  (* RR Set Exists when it should not 	[RFC2136] *)
     8;  (* RR Set that should exist does not 	[RFC2136] *)
     9;  (* Server Not Authoritative for zone 	[RFC2136] *)
         (* and Not Authorized [RFC2845] *)
     10 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition ResponseCode := EnumType ResponseCodes.

  Definition beq_ResponseCode (a b : ResponseCode) : bool
    := fin_beq a b.

  Definition ResponseCode_dec (a b : ResponseCode) :=
    fin_eq_dec a b.
End ResponseCode.

Section OpCode.

  Definition OpCodes :=
    ["Query";    (* RFC1035] *)
     "IQuery"; (* Inverse Query  OBSOLETE) [RFC3425] *)
     "Status"; (* [RFC1035] *)
     "Notify"  (* [RFC1996] [RFC2136] *)
    ].

  Definition OpCode := EnumType OpCodes.

  Definition Opcode_Ws : t (word 4) 4 :=
    Eval simpl in Vector.map (natToWord 4)
                             [0;    (* RFC1035] *)
                              1; (* Inverse Query  OBSOLETE) [RFC3425] *)
                              2; (* [RFC1035] *)
                              4  (* [RFC1996] [RFC2136] *)].

  Definition beq_OpCode (a b : OpCode) : bool
    := fin_beq a b.

  Definition OpCode_dec (a b : OpCode) :=
    fin_eq_dec a b.

End OpCode.

Section Packet.

  (* The question section of a DNS packet. *)
  Definition question :=
    @Tuple <
    "qname" :: DomainName,
    "qtype" :: QType,
    "qclass" :: QClass >%Heading.
  (* ["google", "com"] *)

  (* DNS Resource Records. *)
  Definition sRRecords := "ResourceRecords".
  Definition sNAME := "Name".
  Definition sTTL := "TTL".
  Definition sCLASS := "Class".
  Definition sTYPE := "Type".
  Definition sRDATA := "rdata".
  Definition sRLENGTH := "rlength".

  Definition resourceRecordHeading :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDataType>%Heading.

  Definition resourceRecord := @Tuple resourceRecordHeading.

  (* Variant headings for each RDataType *)
  Definition VariantResourceRecordHeading RDATAT :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDATAT >%Heading.

  Definition VariantResourceRecord RDATAT := @Tuple (VariantResourceRecordHeading RDATAT).

  (* Aliases for the Common Record Types *)
  Definition CNAME_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurCNAME].
  Definition A_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurA ].
  Definition NS_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurNS].
  Definition MX_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurMX].
  Definition SOA_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurSOA].

  Definition RRecord2VariantResourceRecord
             (rr : resourceRecord)
    : VariantResourceRecord ResourceRecordTypeTypes[@(SumType_index ResourceRecordTypeTypes (rr!sRDATA))] :=
    < sNAME :: rr!sNAME,
      sTTL :: rr!sTTL,
      sCLASS :: rr!sCLASS,
      sRDATA :: SumType_proj _ (rr!sRDATA)>.

  Definition VariantResourceRecord2RRecord
             {idx}
             (vrr : VariantResourceRecord ResourceRecordTypeTypes[@idx])
    : resourceRecord :=
    < sNAME :: vrr!sNAME,
      sTTL :: vrr!sTTL,
      sCLASS :: vrr!sCLASS,
      sRDATA :: inj_SumType _ idx (vrr!sRDATA)>.

  Definition CNAME_Record2RRecord
             (vrr : CNAME_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition A_Record2RRecord
             (vrr : A_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition NS_Record2RRecord
             (vrr : NS_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition MX_Record2RRecord
             (vrr : MX_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition SOA_Record2RRecord
             (vrr : SOA_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.

  (* Binary Format of DNS Header:
                              1  1  1  1  1  1
0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                      ID                       |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|QR|   Opcode  |AA|TC|RD|RA|   Z    |   RCODE   |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    QDCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ANCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    NSCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ARCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
   *)

  (* DNS Packet Layout:
+---------------------+
|        Header       |
+---------------------+
|       Question      |
+---------------------+
|        Answer       |
+---------------------+
|      Authority      |
+---------------------+
|      Additional     |
+---------------------+
   *)

(* Unique Request IDs *)
Definition ID : Type := word 16.

  Definition packetHeading :=
    < "id" :: ID, (* 16 bit Word. *)
      "QR" :: bool, (* is packet a query (0), or a response (1) *)
      "Opcode" :: OpCode, (* kind of query in packet *)
      "AA" :: bool, (* is responding server authorative *)
      "TC" :: bool, (* is packet truncated *)
      "RD" :: bool, (* are recursive queries desired *)
      "RA" :: bool, (* are recursive queries supported by responding server *)
      "RCODE" :: ResponseCode, (* response code *)
      "question" :: question, (* `list question` in case we can have multiple questions? *)
      "answers" :: list resourceRecord,
      "authority" :: list resourceRecord,
      "additional" :: list resourceRecord >%Heading.

  Definition packet := @Tuple packetHeading.

  Definition buildempty
             (is_authority : bool)
             (rcode : BoundedIndex ResponseCodes)
             (p : packet)
    : packet :=
    p ○ [ "AA" ::= is_authority; (* Update Authority field *)
          "QR" ::= true; (* Set response flag to true *)
          "RCODE" ::= ibound (indexb rcode);
          "answers" ::= nil;
          "authority"  ::= nil;
          "additional" ::= nil ].

  (* add a resource record to a packet's answers *)
  Definition add_answer
             (p : packet)
             (t : resourceRecord)
    : packet :=
    p ○ [o !! "answers" / t :: o].

  (* add a resource record authority to a packet's authorities
   (ns = name server). *)
  Definition add_ns
             (p : packet)
             (t : resourceRecord)
    : packet :=
    p ○ [o !! "authority" / t :: o].

  (* combine with above? *)
  Definition add_additional
             (p : packet)
             (t : resourceRecord)
    : packet :=
    p ○ [o !! "additional" / t :: o].

  Definition updateRecords
             (p : packet)
             answers' authority' additional'
    : packet :=
    p ○ ["answers" ::= answers';
           "authority" ::= authority';
           "additional" ::= additional'].

  Definition get_name (r : resourceRecord) := r!sNAME.
  Definition name_length (r : resourceRecord) := String.length (get_name r).

  Definition isQuestion (p : packet) :=
    match p!"answers", p!"authority", p!"additional" with
    | nil, nil, nil => true
    | _, _, _ => false
    end.

  Definition is_empty {A} (l : list A) : bool :=
    match l with
    | nil => true
    | _ => false
    end.

  Lemma is_empty_app {A} :
    forall (l l' : list A),
      is_empty (l ++ l') = andb (is_empty l) (is_empty l').
  Proof.
    induction l; simpl; eauto.
  Qed.

  Definition isAnswer (p : packet) := negb (is_empty (p!"answers")).

  Definition isReferral (p : packet) :=
    is_empty (p!"answers")
             && (negb (is_empty (p!"authority")))
             && (negb (is_empty (p!"additional"))).

  Definition add_answers := List.fold_left add_answer.
  Definition add_nses := List.fold_left add_ns.
  Definition add_additionals := List.fold_left add_additional.

End Packet.

Coercion CNAME_Record2RRecord : CNAME_Record >-> resourceRecord.
Coercion A_Record2RRecord : A_Record >-> resourceRecord.
Coercion NS_Record2RRecord : NS_Record >-> resourceRecord.
Coercion MX_Record2RRecord : MX_Record >-> resourceRecord.
Coercion SOA_Record2RRecord : SOA_Record >-> resourceRecord.


Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Require Export FcEtt.tactics.
Require Export FcEtt.imports.
Require Export FcEtt.ett_inf.
Require Export FcEtt.ett_ott.
Require Export FcEtt.ett_ind.

Require Export FcEtt.ext_context_fv.

Require Import FcEtt.ext_wf.
Import ext_wf.

Require Import FcEtt.utils.
Require Import FcEtt.erase_syntax.
Require Export FcEtt.toplevel.

(* ------------------------------------------ *)

(* Paths *)

(*
Lemma Path_tm_subst_tm_tm : forall T a x b, Path T a -> lc_tm b -> Path T (tm_subst_tm_tm b x a).
Proof. induction 1; try destruct rho; simpl; eauto with lngen.
Qed.

Lemma Path_co_subst_co_tm : forall T a x b, Path T a -> lc_co b -> Path T (co_subst_co_tm b x a).
Proof. induction 1; try destruct rho; simpl; eauto with lngen.
Qed.

Hint Resolve Path_tm_subst_tm_tm Path_co_subst_co_tm : lngen.

Lemma Path_unique : forall T1 T2 a, Path T1 a -> Path T2 a -> T1 = T2.
Proof.
  induction 1; intros P; inversion P; auto.
Qed.

(* DataTy *)

Lemma DataTy_tm_subst_tm_tm : forall b x A,
    DataTy A a_Star -> lc_tm b -> DataTy (tm_subst_tm_tm b x A) a_Star.
Proof.
  intros. dependent induction H; simpl; eauto.
  - pick fresh y and apply DT_Pi.
    eauto with lngen.
    autorewrite with subst_open_var; eauto.
  - pick fresh y and apply DT_CPi.
    eauto with lngen.
    autorewrite with subst_open_var; eauto.
Qed.

Lemma DataTy_co_subst_co_tm : forall b x A,
    DataTy A a_Star -> lc_co b -> DataTy (co_subst_co_tm b x A) a_Star.
Proof.
  intros. dependent induction H; simpl; eauto.
  - pick fresh y and apply DT_Pi.
    eauto with lngen.
    autorewrite with subst_open_var; eauto.
  - pick fresh y and apply DT_CPi.
    eauto with lngen.
    autorewrite with subst_open_var; eauto.
Qed.

Hint Resolve DataTy_tm_subst_tm_tm DataTy_co_subst_co_tm : lngen.
*)
(* ------------------------------------------- *)
(*
Definition decide_Path : forall a, lc_tm a -> (exists T, Path T a) \/ (forall T, not (Path T a)).
Proof.
  induction a; intro lc.
  all: try solve [left; eauto].
  all: try solve [right; move => T h1; inversion h1].
  - lc_inversion c. destruct IHa1 as [[T h0]|n].
    auto.
    left; eauto.
    right. move => T h1. inversion h1.
    subst. unfold not in n. eauto.
  - lc_inversion c. destruct IHa as [[T h0]|n].
    auto.
    left; eauto.
    right. intros T h; inversion h; subst; unfold not in n; eauto.
  - lc_inversion c. destruct IHa as [[T h0]|n].
    auto.
    left. exists T. auto.
    right. intros T h; inversion h; subst; unfold not in n; eauto.
Qed.
*)
(* ------------------------------------------- *)

(* Values and CoercedValues *)

Lemma tm_subst_tm_tm_Value_mutual :
  (forall v,  CoercedValue v -> forall b x,  lc_tm b -> CoercedValue (tm_subst_tm_tm b x v)) /\
  (forall v, Value v -> forall b x,  lc_tm b -> Value (tm_subst_tm_tm b x v)).
Proof.
  apply CoercedValue_Value_mutual; simpl.
  all: try solve [inversion 1 | econstructor; eauto]; eauto.
  all: try solve [intros;
                  eauto using tm_subst_tm_tm_lc_tm,
                  tm_subst_tm_constraint_lc_constraint,
                  tm_subst_tm_co_lc_co].
  all: try solve [intros;
    constructor; eauto using tm_subst_tm_tm_lc_tm,  tm_subst_tm_constraint_lc_constraint;
    match goal with [H: lc_tm (?a1 ?a2), K : lc_tm ?b |- _ ] =>
                    move: (tm_subst_tm_tm_lc_tm _ _ x H K) => h0; auto end].

  - intros L a v H b x H0.
    econstructor; eauto.
    instantiate (1 := L \u singleton x) => x0 h0.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm_var; auto.
  - intros L A a l c H b x H0.
    econstructor; eauto.
    apply tm_subst_tm_tm_lc_tm; auto.
    instantiate (1 := L \u singleton x) => x0 h0.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm_var; auto.
Qed.

Lemma Value_tm_subst_tm_tm :
  (forall v b x, Value v -> lc_tm b -> Value (tm_subst_tm_tm b x v)).
Proof.
  intros v b x H H0.
  apply tm_subst_tm_tm_Value_mutual; auto.
Qed.

Lemma CoercedValue_tm_subst_tm_tm :
  (forall v b x, CoercedValue v -> lc_tm b -> CoercedValue (tm_subst_tm_tm b x v)).
Proof.
  intros v b x H H0.
  destruct (tm_subst_tm_tm_Value_mutual); auto.
Qed.

(* ------------------------------------------------- *)

Lemma Value_UAbsIrrel_exists : ∀ x (a : tm),
    x `notin` fv_tm a
    → (Value (open_tm_wrt_tm a (a_Var_f x)))
    → Value (a_UAbs Irrel a).
Proof.
  intros.
  eapply (Value_UAbsIrrel ({{x}})); eauto.
  intros.
  rewrite (tm_subst_tm_tm_intro x); eauto.
  eapply Value_tm_subst_tm_tm; auto.
Qed.

Lemma Value_AbsIrrel_exists : ∀ x (A a : tm),
    x `notin` fv_tm a
    -> lc_tm A
    → (CoercedValue (open_tm_wrt_tm a (a_Var_f x)))
    → Value (a_Abs Irrel A a).
Proof.
  intros.
  eapply (Value_AbsIrrel ({{x}})); eauto.
  intros.
  rewrite (tm_subst_tm_tm_intro x); eauto.
  eapply CoercedValue_tm_subst_tm_tm; auto.
Qed.

(* ----- *)

Lemma co_subst_co_tm_Value_mutual :
  (forall v,  CoercedValue v -> forall b x,  lc_co b -> CoercedValue (co_subst_co_tm b x v)) /\
  (forall v, Value v -> forall b x,  lc_co b -> Value (co_subst_co_tm b x v)).
Proof.
  apply CoercedValue_Value_mutual; simpl.
  all: try solve [inversion 1 | econstructor; eauto]; eauto.
  all: try solve [intros;
                  eauto using co_subst_co_tm_lc_tm,
                  co_subst_co_constraint_lc_constraint,
                  co_subst_co_co_lc_co].
  all: try solve [intros;
    constructor; eauto using co_subst_co_tm_lc_tm,
                              co_subst_co_constraint_lc_constraint;
    match goal with [H: lc_tm (?a1 ?a2), K : lc_co ?b |- _ ] =>
                    move: (co_subst_co_tm_lc_tm _ _ x H K) => h0; auto end].
  - intros.
    pick fresh y.
    eapply Value_UAbsIrrel_exists with (x:=y).
    eapply fv_tm_tm_tm_co_subst_co_tm_notin; eauto.
    move: (H y ltac:(eauto) b x H0) => h0.
    rewrite co_subst_co_tm_open_tm_wrt_tm in h0.
    simpl in h0. auto. auto.
  - intros.
    pick fresh y.
    eapply Value_AbsIrrel_exists with (x:=y).
    eapply fv_tm_tm_tm_co_subst_co_tm_notin; eauto.
    eapply co_subst_co_tm_lc_tm; eauto.
    move: (H y ltac:(eauto) b x H0) => h0.
    rewrite co_subst_co_tm_open_tm_wrt_tm in h0; auto.
Qed.

Lemma Value_co_subst_co_tm :
  (forall v b x, Value v -> lc_co b -> Value (co_subst_co_tm b x v)).
Proof.
  intros v b x H H0.
  apply co_subst_co_tm_Value_mutual; auto.
Qed.

Lemma CoercedValue_co_subst_co_tm :
  (forall v b x, CoercedValue v -> lc_co b -> CoercedValue (co_subst_co_tm b x v)).
Proof.
  intros v b x H H0.
  destruct (co_subst_co_tm_Value_mutual); auto.
Qed.

(* ------------------------------------------ *)

(*
Lemma decide_Value_mutual : forall a,
    lc_tm a ->
    (Value a \/ not (Value a)) /\ (CoercedValue a \/ (not (CoercedValue a))).
Proof.
  induction 1; try destruct rho.
  all: try solve [split; left; auto].
  all: try solve [split; right; intro h; inversion h; try inversion H;
                  try inversion H1].
  - pick fresh x.
    destruct (H1 x) as [[V|NV][CV|NCV]].
    all: try solve [split; left; eauto using Value_AbsIrrel_exists].
    + split;
      right; intro h; inversion h; try inversion H2; subst;
      apply NCV;
      pick fresh y;
      rewrite (tm_subst_tm_tm_intro y); eauto;
      eapply CoercedValue_tm_subst_tm_tm; eauto.
  - pick fresh x.
    destruct (H0 x) as [[V|NV]_].
    all: try solve [split; left; eauto using Value_UAbsIrrel_exists].
    split.
    all: right; intro h; inversion h; try inversion H1; subst; apply NV;
      pick fresh y;
      rewrite (tm_subst_tm_tm_intro y); eauto;
        eapply Value_tm_subst_tm_tm; eauto.
  - destruct (IHlc_tm) as [[V|NV][CV|NCV]].
    all: split.
    all: try solve [left; eauto].
    all: try solve [right; intro h; inversion h; try inversion H1; eapply NP; eauto].
    all: try solve [right; intro h; inversion h; try inversion H1; done].
Qed.

Lemma decide_Value : forall a, lc_tm a -> (Value a \/ not (Value a)).
Proof.
  intros a.
  eapply decide_Value_mutual.
Qed.

Lemma decide_CoercedValue : forall a, lc_tm a -> (CoercedValue a \/ not (CoercedValue a)).
Proof.
  intros a.
  eapply decide_Value_mutual.
Qed.
*)

  (* ------------------------------------------ *)
(*
Lemma DataTy_value_type : forall A, DataTy A a_Star -> value_type A.
Proof.
  intros A H.
  dependent induction H; eauto with lc.
Qed. *)


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Export Pcomb.
Require Export Pcrit.
Require Export Fred.
Require Import moreCoefStructure.
Section BuchAux.
Load "hCoefStructure".
Load "hOrderStructure".
Load "hComb".

Definition red (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)) :=
  reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P
    (s2p A A0 eqA n ltM a) (pO A n).

Definition addEnd :
  poly A0 eqA ltM -> list (poly A0 eqA ltM) -> list (poly A0 eqA ltM).
intros a H'0; elim H'0.
exact (a :: nil).
intros b L1 Rec; exact (b :: Rec).
Defined.

Theorem addEnd_cons :
 forall (a b : poly A0 eqA ltM) (aL : list (poly A0 eqA ltM)),
 In a (addEnd b aL) -> a = b \/ In a aL.
intros a b aL; elim aL; simpl in |- *; auto.
intros H'; case H'; [ intros H'0; rewrite <- H'0 | intros H'0; clear H' ];
 auto.
intros a0 l H' H'0; case H'0;
 [ intros H'1; rewrite <- H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
case (H' H'1); auto.
Qed.

Theorem addEnd_id1 :
 forall (a : poly A0 eqA ltM) (aL : list (poly A0 eqA ltM)),
 In a (addEnd a aL).
intros a aL; elim aL; simpl in |- *; auto.
Qed.

Theorem addEnd_id2 :
 forall (a b : poly A0 eqA ltM) (aL : list (poly A0 eqA ltM)),
 In a aL -> In a (addEnd b aL).
intros a b aL; elim aL; simpl in |- *; auto.
intros a0 l H' H'0; case H'0; auto.
Qed.

Lemma addEnd_app :
 forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 addEnd a P = P ++ a :: nil.
intros a P; elim P; simpl in |- *; auto.
intros a0 l H'; elim H'; auto.
Qed.

Definition spolyp : poly A0 eqA ltM -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros p q; case p; case q.
intros x Cpx x0 Cpx0;
 exists
  (spolyf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec x x0 Cpx
     Cpx0); auto.
apply spolyf_canonical with (1 := cs); auto.
Defined.

Theorem red_com :
 forall (a b : poly A0 eqA ltM) (aL : list (poly A0 eqA ltM)),
 red (spolyp a b) aL -> red (spolyp b a) aL.
intros a b; case a; case b; simpl in |- *.
unfold red in |- *; simpl in |- *.
intros x Cx x0 Cx0 aL H'1; inversion H'1.
cut
 (canonical A0 eqA ltM
    (spolyf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec x x0 Cx
       Cx0)); [ intros Op1 | apply spolyf_canonical with (1 := cs) ];
 auto.
cut
 (canonical A0 eqA ltM
    (spolyf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec x0 x Cx0
       Cx)); [ intros Op2 | apply spolyf_canonical with (1 := cs) ];
 auto.
apply reducestar0; auto.
apply
 reduceplus_eqp_com
  with
    (1 := cs)
    (p := mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            (spolyf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
               x x0 Cx Cx0))
    (q := mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            (pO A n)); auto.
apply reduceplus_mults with (1 := cs); auto.
inversion H; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply spolyf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply spolyf_com with (1 := cs); auto.
Qed.

Theorem rstar_rtopO :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 canonical A0 eqA ltM p ->
 reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p
   (pO A n) ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p
   (pO A n).
intros Q p H' H'0.
elim
 reduce0_reducestar
  with
    (1 := cs)
    (eqA_dec := eqA_dec)
    (ltM_dec := ltM_dec)
    (Q := Q)
    (p := pO A n); auto.
intros t E; apply reducestar0; auto.
apply pO_irreducible; auto.
Qed.

Definition spO : poly A0 eqA ltM.
exists (pO A n); simpl in |- *; auto.
Defined.

Definition sp1 : poly A0 eqA ltM.
exists (pX (A1, M1 n) nil); auto.
Defined.

Definition sgen : nat -> poly A0 eqA ltM.
intros m; exists (pX (A1, gen_mon n m) (pO A n)).
apply canonicalp1; auto.
Defined.

Definition sscal : A -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros a p; case p.
intros x H'1; exists (tmults A0 multA eqA_dec (a, M1 n) x); auto.
unfold tmults in |- *; case (zeroP_dec A A0 eqA eqA_dec n (a, M1 n));
 simpl in |- *; auto.
Qed.

Theorem red_cons :
 forall (a : poly A0 eqA ltM) (p : list (poly A0 eqA ltM)), In a p -> red a p.
intros a; case (seqp_dec A A0 eqA eqA_dec n ltM a spO).
case a; unfold red, spO, seqP in |- *; simpl in |- *.
intros x c H' p H'0; inversion H'; auto.
apply reducestar_pO_is_pO with (p := x); auto.
case a; unfold red, spO, seqP in |- *; simpl in |- *.
intros x c H' p H'0.
apply rstar_rtopO; auto.
apply Rstar_n with (y := pO A n); auto.
apply reduce_in_pO with (1 := cs); auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM
        (exist (fun l : list (Term A n) => canonical A0 eqA ltM l) x c)) p)
 in |- *; apply In_inp_inPolySet; auto.
red in |- *; intros H'2; apply H'; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n);
 auto.
apply Rstar_0; auto.
Qed.

Theorem red_id :
 forall (a : poly A0 eqA ltM) (aL : list (poly A0 eqA ltM)),
 red (spolyp a a) aL.
intros a P; case a.
unfold red in |- *; simpl in |- *; auto.
intros x H'.
apply rstar_rtopO; auto.
apply spolyf_canonical with (1 := cs); auto.
apply Rstar_0; auto.
apply spolyf_pO with (1 := cs); auto.
Qed.

Theorem inP_reduce :
 forall P Q : list (poly A0 eqA ltM),
 (forall a : list (Term A n),
  inPolySet A A0 eqA n ltM a Q -> inPolySet A A0 eqA n ltM a P) ->
 forall a b : list (Term A n),
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q a b ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P a b.
intros P Q H' a b H'0; elim H'0; auto.
intros a0 b0 nZb p q r H'1 H'2 H'3; auto.
apply reducetop with (b := b0) (nZb := nZb) (q := q); auto.
Qed.

Theorem inP_reduceplus :
 forall P Q : list (poly A0 eqA ltM),
 (forall a : list (Term A n),
  inPolySet A A0 eqA n ltM a Q -> inPolySet A A0 eqA n ltM a P) ->
 forall a b : list (Term A n),
 reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q a b ->
 reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P a b.
intros P Q H' a b H'0; elim H'0; auto.
intros; apply Rstar_0; auto.
intros x y z H'1 H'2 H'3.
apply Rstar_n with (y := y); auto.
apply inP_reduce with (Q := Q); auto.
Qed.

Theorem inP_reducestar :
 forall P Q : list (poly A0 eqA ltM),
 (forall a : list (Term A n),
  inPolySet A A0 eqA n ltM a Q -> inPolySet A A0 eqA n ltM a P) ->
 forall a b : list (Term A n),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q a b ->
 reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P a b.
intros P Q H' a b H'0; inversion H'0; auto.
apply inP_reduceplus with (Q := Q); auto.
Qed.

Theorem red_incl :
 forall (a : poly A0 eqA ltM) (p q : list (poly A0 eqA ltM)),
 incl p q -> red a p -> red a q.
unfold red in |- *.
intros a p q H' H'0.
inversion H'0.
apply rstar_rtopO; auto.
case a; auto.
apply inP_reducestar with (Q := p); auto.
intros a0 H'1.
apply Incl_inp_inPolySet with (P := p); auto.
Qed.

Definition zerop : poly A0 eqA ltM -> Prop.
intros H'; case H'.
intros x; case x.
intros H'0; exact True.
intros a l H'0; exact False.
Defined.

Theorem zerop_dec : forall a : poly A0 eqA ltM, {zerop a} + {~ zerop a}.
intros H'; case H'.
intros x; case x.
intros c; left; simpl in |- *; auto.
intros a l c; right; red in |- *; intros H'0; inversion H'0.
Qed.

Definition divp : poly A0 eqA ltM -> poly A0 eqA ltM -> Prop.
intros H'; case H'.
intros x; case x.
intros H'0 H'1; exact False.
intros a l H'0 H'1; case H'1.
intros x0; case x0.
intros H'2; exact False.
intros a0 l0 H'2.
exact (divP A A0 eqA multA divA n a a0).
Defined.

Theorem divp_trans : transitive (poly A0 eqA ltM) divp.
red in |- *.
intros x y z; case x; case y; case z.
intros x0 c x1 c0 x2 c1; generalize c c0 c1; case x0; case x1; case x2;
 simpl in |- *; auto.
intros a l a0 l0 H' H'0 H'1 H'2; elim H'2.
intros a l a0 l0 a1 l1 H' H'0 H'1 H'2 H'3.
apply (divP_trans _ _ _ _ _ _ _ _ _ cs n) with (y := a0); auto.
Qed.

Theorem divp_dec : forall a b : poly A0 eqA ltM, {divp a b} + {~ divp a b}.
intros a b; case a; case b.
intros x c x0 c0; generalize c c0; case x; case x0; simpl in |- *.
intros H' H'0; right; red in |- *; intros H'1; elim H'1.
intros a0 l H' H'0; right; red in |- *; intros H'1; elim H'1.
intros a0 l H' H'0; right; red in |- *; intros H'1; elim H'1.
intros a0 l a1 l0 H' H'0.
apply divP_dec with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0); auto.
Qed.

Definition ppcp : poly A0 eqA ltM -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros H'; case H'.
intros x; case x.
intros H'0 H'1; exists (pO A n); auto.
intros a l H'0 H'1; case H'1.
intros x0; case x0.
intros H'2; exists (pO A n); auto.
intros a0 l0 H'2; exists (ppc (A:=A) A1 (n:=n) a a0 :: pO A n).
change (canonical A0 eqA ltM (pX (ppc (A:=A) A1 (n:=n) a a0) (pO A n)))
 in |- *; apply canonicalp1; auto.
apply ppc_nZ with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0); auto.
Defined.

Theorem divp_ppc :
 forall a b c : poly A0 eqA ltM, divp (ppcp a b) c -> divp (ppcp b a) c.
intros a b c; (case a; case b; case c).
intros x c0 x0 c1 x1 c2; generalize c0 c1 c2; case x; case x0; case x1;
 simpl in |- *; auto.
intros a0 l a1 l0 a2 l1 H' H'0 H'1 H'2.
apply divP_eqTerm_comp with (1 := cs) (a := ppc (A:=A) A1 (n:=n) a0 a1); auto.
Qed.

Theorem zerop_ddivp_ppc :
 forall a b : poly A0 eqA ltM, ~ zerop a -> ~ zerop b -> divp (ppcp a b) b.
intros a b; (case a; case b).
intros x c0 x0 c1; generalize c0 c1; case x; case x0; simpl in |- *; auto.
intros a0 l a1 l0 H' H'0 H'1 H'2.
apply divP_ppcr with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0); auto.
Qed.

Theorem divp_nzeropl : forall a b : poly A0 eqA ltM, divp a b -> ~ zerop a.
intros a b; (case a; case b).
intros x c0 x0 c1; generalize c0 c1; case x; case x0; simpl in |- *; auto.
Qed.

Theorem divp_nzeropr : forall a b : poly A0 eqA ltM, divp a b -> ~ zerop b.
intros a b; (case a; case b).
intros x c0 x0 c1; generalize c0 c1; case x; case x0; simpl in |- *; auto.
Qed.
Hint Resolve pO_irreducible.

Theorem reducetopO_pO :
 forall Q : list (poly A0 eqA ltM),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pO A n) (pO A n).
intros Q; apply reducestar0; auto.
apply Rstar_0; auto.
Qed.
Hint Resolve reducetopO_pO.

Theorem zerop_red_spoly_l :
 forall a b : poly A0 eqA ltM,
 zerop a -> forall Q : list (poly A0 eqA ltM), red (spolyp a b) Q.
intros a b; (case a; case b).
intros x c0 x0 c1; generalize c0 c1; case x; case x0; simpl in |- *; auto.
intros c2 c3 H' Q; unfold red in |- *; simpl in |- *; auto.
intros a0 l c2 c3 H'; elim H'.
intros a0 l c2 c3 H' Q; unfold red in |- *; simpl in |- *; auto.
intros a0 l a1 l0 c2 c3 H'; elim H'.
Qed.

Theorem zerop_red_spoly_r :
 forall a b : poly A0 eqA ltM,
 zerop b -> forall Q : list (poly A0 eqA ltM), red (spolyp a b) Q.
intros a b; (case a; case b).
intros x c0 x0 c1; generalize c0 c1; case x; case x0; simpl in |- *; auto.
intros c2 c3 H' Q; unfold red in |- *; simpl in |- *; auto.
intros a0 l c2 c3 H' Q; unfold red in |- *; simpl in |- *; auto.
intros a0 l c2 c3 H'; elim H'.
intros a0 l a1 l0 c2 c3 H'; elim H'.
Qed.

Theorem divP_ppc :
 forall a b c : poly A0 eqA ltM, divp a b -> divp a c -> divp a (ppcp b c).
intros a b c; (case a; case b; case c).
intros x c0 x0 c1 x1 c2; generalize c0 c1 c2; case x; case x0; case x1;
 simpl in |- *; auto.
intros a0 l a1 l0 a2 l1 H' H'0 H'1 H'2 H'3.
elim ppc_is_ppcm with (1 := cs) (a := a1) (b := a2); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l1); auto.
Qed.

Definition Cb : poly A0 eqA ltM -> list (poly A0 eqA ltM) -> Prop.
intros H'; case H'.
intros x H'0 Q;
 exact (CombLinear A A0 eqA plusA multA eqA_dec n ltM ltM_dec Q x).
Defined.

Theorem Cb_id :
 forall (a : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)), In a Q -> Cb a Q.
intros a; case a; simpl in |- *.
intros x; case x; auto.
intros c Q H'.
replace (nil (A:=Term A n)) with (pO A n); auto; apply CombLinear_0; auto.
intros a0 l c Q H'.
apply CombLinear_id with (1 := cs); auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM (mks A A0 eqA n ltM (pX a0 l) c)) Q)
 in |- *; apply in_inPolySet; auto.
red in |- *; intros H'4; inversion H'4.
Qed.

Theorem inPolySet_addEnd :
 forall (a : list (Term A n)) (p : poly A0 eqA ltM)
   (l : list (poly A0 eqA ltM)),
 inPolySet A A0 eqA n ltM a (addEnd p l) ->
 a = s2p A A0 eqA n ltM p \/ inPolySet A A0 eqA n ltM a l.
intros a p l; elim l; simpl in |- *; auto.
intros H'; inversion H'; auto.
intros a0 l0 H' H'0; inversion H'0; auto.
right.
exact (incons A A0 eqA n ltM a1 p0 H l0).
case H'; auto.
intros H3; right; try assumption.
apply inskip; auto.
Qed.

Remark CombLinear_trans1 :
 forall (a : list (Term A n)) (R : list (poly A0 eqA ltM)),
 CombLinear A A0 eqA plusA multA eqA_dec n ltM ltM_dec R a ->
 forall (b : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)),
 R = addEnd b Q ->
 CombLinear A A0 eqA plusA multA eqA_dec n ltM ltM_dec Q
   (s2p A A0 eqA n ltM b) ->
 CombLinear A A0 eqA plusA multA eqA_dec n ltM ltM_dec Q a.
intros a R H'; elim H'; auto.
intros b Q H'0 H'1.
apply CombLinear_0; auto.
intros a0 p q s H'0 H'1 H'2 H'3 H'4 b Q H'5 H'6.
apply
 CombLinear_comp
  with
    (1 := cs)
    (p := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a0 q) p); auto.
2: apply
    eqp_imp_canonical
     with
       (1 := cs)
       (p := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a0 q) p);
    auto.
2: apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
2: apply canonical_pluspf with (1 := os); auto.
2: apply canonical_mults with (1 := cs); auto.
2: apply inPolySet_imp_canonical with (L := R); auto.
2: apply
    CombLinear_canonical
     with (eqA_dec := eqA_dec) (ltM_dec := ltM_dec) (1 := cs) (Q := R);
    auto.
2: apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply CombLinear_pluspf with (1 := cs); auto.
apply CombLinear_mults1 with (1 := cs); auto.
2: apply H'3 with (b := b); auto.
case (inPolySet_addEnd q b Q); auto.
rewrite <- H'5; auto.
intros H'7; rewrite H'7; auto.
intros; (apply CombLinear_id with (1 := cs); auto).
Qed.

Theorem Cb_trans :
 forall (a b : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)),
 Cb a (addEnd b Q) -> Cb b Q -> Cb a Q.
intros a b; case a; case b; simpl in |- *; auto.
intros x c x0 H' Q H'0 H'1.
apply
 CombLinear_trans1
  with
    (R := addEnd
            (exist (fun l : list (Term A n) => canonical A0 eqA ltM l) x c) Q)
    (b := exist (fun l : list (Term A n) => canonical A0 eqA ltM l) x c);
 auto.
Qed.

Theorem Cb_incl :
 forall (a : poly A0 eqA ltM) (P Q : list (poly A0 eqA ltM)),
 (forall a : poly A0 eqA ltM, In a P -> In a Q) -> Cb a P -> Cb a Q.
intros a; case a; simpl in |- *; auto.
intros x H' P Q H'0 H'1.
apply CombLinear_incl with (1 := cs) (P := P); auto.
intros a0 H'2.
apply Incl_inp_inPolySet with (P := P); auto.
Qed.

Theorem Cb_in1 :
 forall (a b : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)),
 Cb a Q -> Cb a (b :: Q).
intros a b Q H'.
apply Cb_incl with (P := Q); simpl in |- *; auto.
Qed.

Theorem Cb_in :
 forall (a b : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)),
 Cb a Q -> Cb a (addEnd b Q).
intros a b Q H'.
apply Cb_incl with (P := Q); simpl in |- *; auto.
intros a0 H'0; apply addEnd_id2; auto.
Qed.

Theorem Cb_sp :
 forall (a b : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)),
 Cb a Q -> Cb b Q -> Cb (spolyp a b) Q.
intros a b; case a; case b; simpl in |- *; auto.
intros x; case x; auto.
intros a0 l H' x0; case x0; auto.
intros a1 l0 H'0 Q H'1 H'2.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := l); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) a1);
 [ intros Z1 | apply canonical_nzeroP with (ltM := ltM) (p := l0); auto ].
apply
 CombLinear_comp
  with
    (1 := cs)
    (p := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a0) Z0)
               (pX a0 l))
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a1) Z1)
               (pX a1 l0))); auto.
apply CombLinear_minuspf with (1 := cs); auto.
apply CombLinear_mults1 with (1 := cs); auto.
apply CombLinear_mults1 with (1 := cs); auto.
apply spolyf_canonical with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
change
  (eqP A eqA n
     (spolyf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
        (pX a0 l) (pX a1 l0) H' H'0)
     (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
        (mults (A:=A) multA (n:=n)
           (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
              (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a0) Z0)
           (pX a0 l))
        (mults (A:=A) multA (n:=n)
           (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
              (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a1) Z1)
           (pX a1 l0)))) in |- *.
apply spoly_is_minus with (1 := cs); auto.
Qed.

Definition unit : poly A0 eqA ltM -> Term A n.
intros p; case p.
intros x; case x.
intros H'; exact (T1 A1 n).
intros a l; case a.
intros co m H'; cut (~ eqA co A0).
intros H'0; exact (divA A1 co H'0, M1 n).
inversion H'; auto.
simpl in H0.
intuition.
Defined.

Theorem unit_T1 : forall p : poly A0 eqA ltM, eqT (unit p) (T1 A1 n).
unfold eqT in |- *; intros p; case p.
intros x; case x; simpl in |- *; auto.
intros a l; case a; simpl in |- *; auto.
Qed.

Theorem divA_nZ :
 forall a b : A,
 ~ eqA b A0 -> forall nZa : ~ eqA a A0, ~ eqA (divA b a nZa) A0.
intros a b H' nZa; red in |- *; intros H'1; auto.
case H';
 apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA (divA b a nZa) a);
 auto.
apply divA_is_multA with (1 := cs); auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := multA A0 a); auto.
apply multA_eqA_comp with (1 := cs); auto.
apply (eqA_ref _ _ _ _ _ _ _ _ _ cs); auto.
apply multA_A0_l with (1 := cs); auto.
Qed.
Hint Resolve divA_nZ.

Theorem unit_nZ :
 forall p : poly A0 eqA ltM, ~ zeroP (A:=A) A0 eqA (n:=n) (unit p).
intros p; case p.
intros x; case x; simpl in |- *; auto.
intros a l; case a; simpl in |- *; auto.
Qed.

Definition nf : poly A0 eqA ltM -> list (poly A0 eqA ltM) -> poly A0 eqA ltM.
intros p L.
case
 (Reducef A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
    os L p).
intros x H'.
apply LetP with (A := poly A0 eqA ltM) (h := x).
intros u H'1; case u.
intros x0 H'2;
 exists (mults (A:=A) multA (n:=n) (unit (mks A A0 eqA n ltM x0 H'2)) x0);
 auto.
apply canonical_mults with (1 := cs); auto.
apply unit_nZ; auto.
Defined.

Theorem nf_irreducible :
 forall (p : poly A0 eqA ltM) (aP : list (poly A0 eqA ltM)),
 irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec aP
   (s2p A A0 eqA n ltM (nf p aP)).
unfold nf in |- *.
intros p aP;
 case
  (Reducef A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
     os aP p).
intros x; case x; simpl in |- *; auto.
intros x0 c H'; inversion H'.
red in H0.
red in |- *; red in |- *.
intros q0; intros H'0; auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (unit (mks A A0 eqA n ltM x0 c)));
 [ intros nZd | idtac ]; auto.
apply
 H0
   with
     (q := mults (A:=A) multA (n:=n)
             (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                (T1 A1 n) (b:=unit (mks A A0 eqA n ltM x0 c)) nZd) q0);
 auto.
apply reduce_mults_invf with (1 := cs); auto.
apply unit_T1; auto.
apply unit_nZ; auto.
Qed.

Theorem nf_red :
 forall (a : poly A0 eqA ltM) (aP aQ : list (poly A0 eqA ltM)),
 incl aP aQ -> red (nf a aP) aQ -> red a aQ.
intros a; case a; simpl in |- *.
unfold red in |- *; unfold nf in |- *; simpl in |- *; auto.
intros x c aP aQ H';
 case
  (Reducef A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
     os aP (exist (fun a => canonical A0 eqA ltM a) x c));
 simpl in |- *; auto.
intros x0; case x0; simpl in |- *; auto.
intros x1 c0 H'0 H'1.
apply rstar_rtopO; auto.
apply reduceplus_trans with (Q := aQ) (1 := cs) (y := x1); auto.
inversion H'0; auto.
apply inP_reduceplus with (Q := aP); auto.
intros a0 H'3.
apply Incl_inp_inPolySet with (P := aP); auto.
apply
 reduceplus_mults_inv with (1 := cs) (a := unit (mks A A0 eqA n ltM x1 c0));
 auto.
apply unit_nZ; auto.
apply unit_T1; auto.
inversion H'1; inversion H; auto.
Qed.

Theorem red_zerop :
 forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 red (nf a P) P -> zerop (nf a P).
unfold nf in |- *.
intros p aP; case p.
intros x c.
case
 (Reducef A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
    os aP (exist (fun l => canonical A0 eqA ltM l) x c));
 auto.
unfold red in |- *; auto.
intros x0; case x0.
intros x1; case x1.
simpl in |- *; auto.
intros a l c0 H' H'0; inversion H'.
simpl in |- *.
change
  (reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec aP
     (mults (A:=A) multA (n:=n) (unit (mks A A0 eqA n ltM (a :: l) c0))
        (a :: l)) (pO A n)) in H'0.
inversion H'0.
inversion H3.
inversion H7.
simpl in H0.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (unit (mks A A0 eqA n ltM (pX a l) c0)));
 [ intros nZd | idtac ]; auto.
case
 (H0
    (mults (A:=A) multA (n:=n)
       (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
          (T1 A1 n) (b:=unit (mks A A0 eqA n ltM (pX a l) c0)) nZd) y));
 auto.
apply reduce_mults_invf with (1 := cs); auto.
apply unit_T1; auto.
apply unit_nZ; auto.
Qed.

Theorem zerop_red :
 forall (a : poly A0 eqA ltM) (aP : list (poly A0 eqA ltM)),
 zerop (nf a aP) -> red a aP.
intros a aP H'.
apply nf_red with (aP := aP); auto with datatypes.
generalize H'; case (nf a aP); simpl in |- *; auto.
intros x; case x; simpl in |- *; auto.
intros c H'0; red in |- *; simpl in |- *; auto.
intros a0 l H'0 H'1; elim H'1; auto.
Qed.

Theorem canonical_s2p :
 forall x : poly A0 eqA ltM, canonical A0 eqA ltM (s2p A A0 eqA n ltM x).
intros x; case x; auto.
Qed.
Hint Resolve canonical_s2p.

Theorem nf_Cb :
 forall (a : poly A0 eqA ltM) (aP : list (poly A0 eqA ltM)),
 Cb a aP -> Cb (nf a aP) aP.
intros a; case a; unfold nf, Cb in |- *; auto.
intros x c Q H';
 case
  (Reducef A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
     os Q (exist (fun l : list (Term A n) => canonical A0 eqA ltM l) x c));
 auto.
intros x0; case x0.
intros x1 H'0 H'1.
change
  (CombLinear A A0 eqA plusA multA eqA_dec n ltM ltM_dec Q
     (mults (A:=A) multA (n:=n) (unit (mks A A0 eqA n ltM x1 H'0)) x1))
 in |- *.
apply CombLinear_mults1 with (1 := cs); auto.
apply unit_nZ; auto.
apply reducestar_cb with (a := x) (1 := cs); auto.
Qed.

Definition foreigner : poly A0 eqA ltM -> poly A0 eqA ltM -> Prop.
intros a b; case a; case b.
intros x; case x.
intros H' x0 H'0; exact True.
intros a0 l H' x0; case x0.
intros H'0; exact True.
intros a1 l0 H'0;
 exact
  (eqT (ppc (A:=A) A1 (n:=n) a0 a1) (multTerm (A:=A) multA (n:=n) a0 a1)).
Defined.

Definition foreigner_dec :
  forall a b : poly A0 eqA ltM, {foreigner a b} + {~ foreigner a b}.
intros a b; case a; case b.
intros x; case x.
simpl in |- *; auto.
intros a0 l c x0; case x0; simpl in |- *; auto.
intros a1 l0 H'.
apply eqT_dec; auto.
Defined.

Theorem foreigner_red :
 forall (a b : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 foreigner a b -> In a P -> In b P -> red (spolyp a b) P.
intros a b; case a; case b.
intros x; case x.
simpl in |- *; auto.
unfold red in |- *; simpl in |- *; auto.
intros a0 l c x0; case x0.
unfold red in |- *; simpl in |- *; auto.
unfold red in |- *; simpl in |- *; auto.
intros a1 l0 c0 P H' H'0 H'1.
unfold LetP in |- *; simpl in |- *; auto.
apply
 reducestar_eqp_com
  with
    (1 := cs)
    (p := spolyf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
            (pX a0 l) (pX a1 l0) c c0)
    (q := pO A n); auto.
apply spoly_Reducestar_ppc with (1 := cs); auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM (mks A A0 eqA n ltM (pX a1 l0) c0)) P)
 in |- *.
apply in_inPolySet; auto.
red in |- *; intros H'3; inversion H'3; auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM (mks A A0 eqA n ltM (pX a0 l) c)) P)
 in |- *.
apply in_inPolySet; auto.
red in |- *; intros H'3; inversion H'3; auto.
apply spolyf_canonical with (1 := cs); auto.
Qed.
End BuchAux.


From Equations Require Import Equations.

Inductive t (u : unit) :=
| strange : t tt  -> t u.

Derive NoConfusionHom for t.
Fail Derive Subterm for t.

Inductive t' (u : unit) : Set :=
| strange' : t' tt  -> t' u.

Derive NoConfusionHom for t'.
Derive Subterm for t'.
Definition test := well_founded_t'_subterm.


From Coq.Lists Require Import List.
From Equations Require Import Equations.

(* This type is from VST:
 * https://github.com/PrincetonUniversity/VST/blob/v2.1/floyd/compact_prod_sum.v#L13 *)
Fixpoint compact_sum (T: list Type): Type :=
  match T with
  | nil => unit
  | t :: nil => t
  | t :: T0 => (t + compact_sum T0)%type
end.

(* The rest is a nonsensical, just to give a minimalistic reproducible example *)
Inductive Foo :=
| Sum : list Foo -> Foo.

Equations foo_type (t : Foo) : Type :=
  foo_type (Sum u) := compact_sum (List.map foo_type u).

(* Moving val into the return type, rather than having it as an argument might be
 * unnecessary if https://github.com/mattam82/Coq-Equations/issues/73 was fixed *)
Fail Equations do_foo (f : Foo) : forall (val : foo_type f), nat := {
  do_foo (Sum u) := fun val => do_foo_sum u val }

  where
  do_foo_sum (fs : list Foo) : forall val : compact_sum (List.map foo_type fs), nat
     by struct fs := {
    do_foo_sum nil := fun val => 0;
    (* Attempting to work around https://github.com/mattam82/Coq-Equations/issues/78 *)
    do_foo_sum (cons hd tl) with (fun val => do_foo_sum tl val) => {
      do_foo_sum (cons var nil) := fun val => do_foo var val;
      do_foo_sum (cons hd tl) do_foo_tl := fun val =>
        match val with
        | inl v => do_foo hd v
        | inr vs => do_foo_tl vs
        end }}.


Set Warnings "-notation-overridden,-parsing".
From Tweetnacl_verif Require Import init_tweetnacl.
From Tweetnacl.Low Require Import Car25519.
From Tweetnacl.Low Require Import Car25519_bounds.
From Tweetnacl_verif Require Import spec_set25519.
From Tweetnacl_verif Require Import spec_sel25519.
From Tweetnacl_verif Require Import spec_car25519.
From Tweetnacl_verif Require Import spec_pack25519.

Open Scope Z.

Definition Gprog : funspecs :=
      ltac:(with_library prog [pack25519_spec; car25519_spec; set25519_spec; sel25519_spec]).

Lemma bound_impl_247_262: forall x : ℤ, 38 * - 2 ^ 47 <= x < 2 ^ 16 + 38 * 2 ^ 47 -> - 2 ^ 62 < x < 2 ^ 62.
Proof. intros. solve_bounds_by_values. Qed.

Lemma verif_pack25519_1: forall Tsh n,
  writable_share Tsh ->
  Zlength n = 16 ->
  Forall (fun x : ℤ => - 2 ^ 62 < x < 2 ^ 62) n ->
  writable_share Tsh /\ Forall (fun x : ℤ => - 2 ^ 62 < x < 2 ^ 62) (car25519 n) /\ Zlength (car25519 n) = 16.
Proof.
intros Tsh n HTsh Hln Hbn.
repeat match goal with
| _ => assumption
| _ => apply bound_impl_247_262
| [ |- _ /\ _ ] => split
| _ => solve[rewrite car25519_Zlength ; auto]
| _ => apply Zcar25519_bounds_length_1
| _ => solve[rewrite Zlength_correct in Hln ; omega]
| _ => eapply list.Forall_impl
end.
Qed.

Lemma verif_pack25519_2:
forall Tsh n,
  writable_share Tsh ->
  Zlength n = 16 ->
  Forall (fun x : ℤ => - 2 ^ 62 < x < 2 ^ 62) n ->
writable_share Tsh /\
Forall (fun x : ℤ => - 2 ^ 62 < x < 2 ^ 62) (car25519 (car25519 n)) /\ Zlength (car25519 (car25519 n)) = 16.
Proof.
intros Tsh n HTsh Hln Hbn.
repeat match goal with
| _ => assumption
| _ => apply bound_impl_247_262
| [ |- _ /\ _ ] => split
| _ => solve[rewrite ?car25519_Zlength ; auto]
| _ => apply Zcar25519_bounds_length_1
| _ => solve[rewrite Zlength_correct in Hln ; omega]
| _ => eapply list.Forall_impl
| _ => rewrite ?car25519_length
end.
Qed.

Lemma verif_pack25519_4:
forall t',
Zlength t' = 16 ->
Forall (fun x : ℤ => 0 <= x < 2 ^ 16) t'->
Int64.min_signed <= Znth 0 t' 0 - 65517 <= Int64.max_signed.
Proof.
intros.
assert(Int64.min_signed + 65517 <= Znth 0 t' 0  <= Int64.max_signed  + 65517).
solve_bounds_by_values_Znth.
omega.
Qed.

Lemma verif_pack25519_5':
forall t' : list ℤ,
Zlength t' = 16 ->
Forall (fun x : ℤ => 0 <= x < 2 ^ 16) t' ->
forall i : ℤ,
1 <= i < 15 ->
forall m''' : list ℤ,
Zlength m''' = 16 ->
Zlength (mVI64 m''') = 16 ->
Zlength (mVI64 t') = 16 ->
Int64.min_signed <=
Znth i t' 0 - 65535 -
Int64.signed (Int64.and (Int64.shr (Int64.repr (Znth (i - 1) m''' 0)) (Int64.repr 16)) (Int64.repr 1)) <=
Int64.max_signed /\ Int64.min_signed <= Int64.signed (Int64.repr (Znth i t' 0)) - 65535 <= Int64.max_signed.
Proof.
split.
2: solve_bounds_by_values_Znth.
rewrite and64_repr.
remember (Z.shiftr (Int64.signed (Int64.repr (Znth (i - 1) m''' 0))) (Int64.unsigned (Int64.repr 16))) as mi1.
assert(0 <= Z.land mi1 1 <= 1) by apply and_0_or_1.
assert(HZland: Z.land mi1 1 = 0 \/ Z.land mi1 1 = 1) by omega.
destruct HZland as [HZland | HZland]; rewrite HZland.
1,2: assert(Int64.min_signed + 65536 <= Znth i t' 0 <= Int64.max_signed  + 65535) by
solve_bounds_by_values_Znth.
all: rewrite ?Int64.signed_repr.
all: solve_bounds_by_values.
Qed.

Lemma verif_pack25519_8:
forall t' : list ℤ,
Zlength t' = 16 ->
Forall (fun x : ℤ => 0 <= x < 2 ^ 16) t' ->
Zlength (mVI64 t') = 16 ->
forall mi1 : ℤ,
Int64.min_signed <=
Znth 15 t' 0 - 32767 -
Int64.signed (Int64.and (Int64.shr (Int64.repr mi1) (Int64.repr 16)) (Int64.repr 1)) <= Int64.max_signed /\
Int64.min_signed <= Int64.signed (Int64.repr (Znth 15 t' 0)) - 32767 <= Int64.max_signed.
Proof.
intros.
assert(0 <= Z.land (Z.shiftr (Int64.signed (Int64.repr mi1)) (Int64.unsigned (Int64.repr 16))) 1 <= 1).
apply and_0_or_1.
rewrite and64_repr.
assert(HZland: Z.land (Z.shiftr (Int64.signed (Int64.repr mi1)) (Int64.unsigned (Int64.repr 16))) 1 = 0 \/
  Z.land (Z.shiftr (Int64.signed (Int64.repr mi1)) (Int64.unsigned (Int64.repr 16))) 1 = 1) by omega.
destruct HZland as [HZland | HZland]; rewrite HZland.
1,2: assert(Int64.min_signed + 32767 <= Znth 15 t' 0 <= Int64.max_signed  + 32767).
2,4: repeat rewrite Int64.signed_repr.
2,6: split.
all: try solve[apply Forall_Znth ; [omega|]; eapply list.Forall_impl ; [eassumption |];
intros x Hx ; simpl in Hx ; solve_bounds_by_values].
all: solve_bounds_by_values.
Qed.

Close Scope Z.


From cap_machine Require Export rules_binary_base rules_Store.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_spec_rules.
  Context `{cfgSG Σ, MachineParameters, invG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : cap_lang.state.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Ltac iFailStep_alt fail_type :=
    iMod (exprspec_mapsto_update _ _ (fill _ (Instr Failed)) with "Hown Hj") as "[Hown Hj]";
    iMod ("Hclose" with "[Hown]") as "_";
    [iNext;iExists _,_;iFrame;iPureIntro;eapply rtc_r;eauto;prim_step_from_exec|];
    iExists (FailedV),_,_; iFrame;iModIntro;iFailCore fail_type.

  Lemma step_store Ep K
     pc_p pc_g pc_b pc_e pc_a
     r1 (r2 : Z + RegName) w mem regs :
   decodeInstrW w = Store r1 r2 →
   isCorrectPC (inr (pc_p, pc_g, pc_b, pc_e, pc_a)) →
   regs !! PC = Some (inr (pc_p, pc_g, pc_b, pc_e, pc_a)) →
   regs_of (Store r1 r2) ⊆ dom _ regs →
   mem !! pc_a = Some w →
   allow_store_map_or_true r1 r2 regs mem →
   nclose specN ⊆ Ep →

   spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ (▷ [∗ map] a↦w ∈ mem, a ↣ₐ w) ∗ (▷ [∗ map] k↦y ∈ regs, k ↣ᵣ y)
   ={Ep}=∗ ∃ retv regs' mem', ⌜ Store_spec regs r1 r2 regs' mem mem' retv⌝ ∗
                           ⤇ fill K (of_val retv) ∗ ([∗ map] a↦w ∈ mem', a ↣ₐ w) ∗ [∗ map] k↦y ∈ regs', k ↣ᵣ y.
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs Hmem_pc HaStore Hnclose) "(Hinv & Hj & >Hmem & >Hmap)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (regspec_heap_valid_inclSepM with "Hown Hmap") as %Hregs.

    (* Derive necessary register values in r *)
    pose proof (lookup_weaken _ _ _ _ HPC Hregs).
    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
    feed destruct (Hri r1) as [r1v [Hr'1 Hr1]]. by set_solver+.
    pose proof (regs_lookup_eq _ _ _ Hr'1) as Hr''1.
    iDestruct (memspec_heap_valid_inSepM _ _ _ _ pc_a with "Hown Hmem") as %Hma; eauto.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.
    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto.

     simpl in Hr1, Hma. option_locate_mr σm σr.
     assert (Hstep':=Hstep). cbn in Hstep. rewrite Hσrr1 in Hstep.

     (* Now we start splitting on the different cases in the Load spec, and prove them one at a time *)
     destruct r1v as  [| (([[p g] b] & e) & a) ] eqn:Hr1v.
     { (* Failure: r1 is not a capability *)
       assert (c = Failed ∧ σ2 = (σr, σm)) as (-> & ->)
           by (destruct r2; inversion Hstep; auto).
       iMod (exprspec_mapsto_update _ _ (fill K (Instr Failed)) with "Hown Hj") as "[Hown Hj]".
       iMod ("Hclose" with "[Hown]") as "_".
       { iNext. iExists _,_;iFrame.
         iPureIntro. eapply rtc_r;eauto. prim_step_from_exec. }
       iExists (FailedV),_,_; iFrame. iModIntro.
       iPureIntro. econstructor; eauto. econstructor; eauto.
     }

     destruct (writeAllowed p && withinBounds (p, g, b, e, a)) eqn:HWA; rewrite HWA in Hstep.
     2 : { (* Failure: r2 is either not within bounds or doesnt allow reading *)
        assert (c = Failed ∧ σ2 = (σr, σm)) as (-> & ->)
         by (destruct r2; inversion Hstep; auto).
       apply andb_false_iff in HWA.
       iFailStep_alt Store_fail_bounds.
     }
     apply andb_true_iff in HWA; destruct HWA as (Hwa & Hwb).

     destruct (word_of_argument regs r2) as [ storev | ] eqn:HSV.
     2: {
       destruct r2 as [z | r2].
       - cbn in HSV; inversion HSV.
       - destruct (Hri r2) as [r0v [Hr0 _] ]. by set_solver+.
         cbn in HSV. rewrite Hr0 in HSV. inversion HSV.
     }
     assert (word_of_argument σr r2 = Some(storev)) as HSVr.
     { destruct r2; cbn in HSV. inversion HSV; simpl in H3;auto;by rewrite H3.
       destruct (Hri r) as [r0v [Hregs0 Hr0] ].  by set_solver+.
       rewrite -Hr0 in Hregs0; rewrite Hregs0 in HSV. exact HSV.
     }

     case_eq (canStore p a storev); intro HcanStore.
     2:{ destruct r2.
         - simpl in HSV; inv HSV. simpl in HcanStore; congruence.
         - assert (c = Failed ∧ σ2 = (σr, σm)) as (-> & ->).
           { simpl in HSV; inv HSV. rewrite /= in HSVr.
             rewrite /= /RegLocate in Hstep.
             destruct (σr !! r); try congruence. inv HSVr.
             rewrite HcanStore in Hstep. inv Hstep; auto. }
           iFailStep_alt Store_fail_invalid_locality.
     }

     (* Prove that a is in the memory map now, otherwise we cannot continue *)
     pose proof (allow_store_implies_storev r1 r2 mem regs p g b e a storev) as (oldv & Hmema); auto.

     (* Given this, prove that a is also present in the memory itself *)
     iDestruct (memspec_v_implies_m_v mem (σr,σm) _ b e a oldv with "Hmem Hown" ) as %Hma ; auto.

     (* Regardless of whether we increment the PC, the memory will change: destruct on the PC later *)
     assert (updatePC (update_mem (σr, σm) a storev) = (c, σ2)) as HH.
      { destruct r2.
       - cbv in HSVr; inversion HSVr; subst storev. done.
       - destruct (σr !r! r) eqn:Hr0.
         * destruct (Hri r) as [r0v [Hregs01 Hr01] ]. by set_solver+.
           assert(is_Some( σr !! r )) as Hrr0. by exists r0v.
           pose proof (regs_lookup_inl_eq σr r z Hrr0 Hr0) as Hr0'.
           simpl in HSVr; rewrite Hr0' in HSVr.
           inversion HSVr; subst storev. done.
         * destruct_cap c0.
           epose proof (regs_lookup_inr_eq σr r _ _ _ _ _ Hr0) as Hr0'.
           simpl in HSVr; rewrite Hr0' in HSVr; inversion HSVr.
           subst storev; clear HSVr.
           rewrite HcanStore /= in Hstep.
           auto.
      }
      iMod ((memspec_heap_update_inSepM _ _ _ a storev) with "Hown Hmem") as "[Hown Hmem]"; eauto.

      destruct (incrementPC regs ) as [ regs' |] eqn:Hregs'.
      2: { (* Failure: the PC could not be incremented correctly *)
        assert (incrementPC σr = None).
        { eapply incrementPC_overflow_mono; first eapply Hregs'; eauto. }
        rewrite incrementPC_fail_updatePC /= in HH; auto.
        inversion HH. subst.
        iMod (exprspec_mapsto_update _ _ (fill _ (Instr Failed)) with "Hown Hj") as "[Hown Hj]";
          iMod ("Hclose" with "[Hown]") as "_";
          [iNext;iExists _,_;iFrame;iPureIntro;eapply rtc_r;eauto;prim_step_from_exec|];
          iExists (FailedV),_,_; iFrame;iModIntro.
        iPureIntro. econstructor. eapply Store_fail_invalid_PC. eauto.
      }

     (* Success *)
      clear Hstep. rewrite /update_mem /= in HH.
      eapply (incrementPC_success_updatePC _ (<[a:=storev]> σm)) in Hregs'
        as (p1 & g1 & b1 & e1 & a1 & a_pc1 & HPC'' & Hincr & HuPC & -> & ?).
      eapply (updatePC_success_incl _ (<[a:=storev]> σm)) in HuPC. 2: by eauto.
      rewrite HuPC in HH; clear HuPC; inversion HH; clear HH; subst c σ2. cbn.
      iMod ((regspec_heap_update_inSepM _ _ _ PC) with "Hown Hmap") as "[Hown Hmap]"; eauto.
      iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
      iExists NextIV,_,_. iFrame.
      iMod ("Hclose" with "[Hown]") as "_".
      { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
        prim_step_from_exec. }

      iPureIntro. eapply Store_spec_success; eauto.
        * split; auto. exact Hr'1. all: auto.
        * unfold incrementPC. rewrite HPC'' Hincr. destruct p1; naive_solver.
  Qed.

  Lemma step_store_success_reg E K pc_p pc_g pc_b pc_e pc_a pc_a' w dst src w'
         p g b e a w'' :
      decodeInstrW w = Store dst (inr src) →
     isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
     (pc_a + 1)%a = Some pc_a' →
     writeAllowed p = true ∧ withinBounds (p, g, b, e, a) = true →
     canStore p a w'' = true ->
     nclose specN ⊆ E →

     spec_ctx ∗ ⤇ fill K (Instr Executable)
              ∗  ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
              ∗ ▷ pc_a ↣ₐ w
              ∗ ▷ src ↣ᵣ w''
              ∗ ▷ dst ↣ᵣ inr (p,g,b,e,a)
              ∗ ▷ a ↣ₐ w'
     ={E}=∗ ⤇ fill K (Instr NextI)
         ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
         ∗ pc_a ↣ₐ w
         ∗ src ↣ᵣ w''
         ∗ dst ↣ᵣ inr (p,g,b,e,a)
         ∗ a ↣ₐ w''.
  Proof.
    iIntros (Hinstr Hvpc Hpca' [Hwa Hwb] Hcanstore Hnclose)
            "(Hown & Hj & >HPC & >Hi & >Hsrc & >Hdst & >Hsrca)".
    iDestruct (rules_binary_base.map_of_regs_3 with "HPC Hsrc Hdst") as "[Hmap (%&%&%)]".
    iDestruct (spec_memMap_resource_2ne_apply with "Hi Hsrca") as "[Hmem %]"; auto.

    iMod (step_store _ _ pc_p with "[$Hown $Hj $Hmap $Hmem]") as (retv regs' mem' Hspec) "(Hj & Hmem & Hregs)";
      eauto; simplify_map_eq_alt; try rewrite lookup_insert; eauto.
    { by rewrite !dom_insert; set_solver+. }
    { eapply mem_neq_implies_allow_store_map with (a := a); eauto.
      rewrite lookup_insert_ne// lookup_insert_ne// lookup_insert;eauto.
      rewrite /word_of_argument. rewrite lookup_insert_ne// lookup_insert. eauto.
    }

    destruct Hspec.
     { (* Success *)
       destruct H7 as [Hrr2 _]. simpl in *. simplify_map_eq_alt. simplify_map_eq.
       rewrite insert_commute // insert_insert.
       iDestruct (rules_binary_base.memMap_resource_2ne with "Hmem") as "[Hpc_a Ha]";auto.
       incrementPC_inv.
       simplify_map_eq_alt.
       rewrite insert_insert.
       iDestruct (rules_binary_base.regs_of_map_3 with "[$Hregs]") as "[HPC [Hsrc Hdst] ]"; eauto. iFrame. done. }
     { (* Failure (contradiction) *)
       destruct X; simpl in *; simplify_map_eq_alt.
       destruct o. all: try congruence.
       incrementPC_inv;[|rewrite lookup_insert;eauto].
       destruct e0; try congruence. inv Hvpc; naive_solver.
     }
    Qed.

  Lemma step_store_success_z E K pc_p pc_g pc_b pc_e pc_a pc_a' w dst z w'
         p g b e a :
     decodeInstrW w = Store dst (inl z) →
     isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
     (pc_a + 1)%a = Some pc_a' →
     writeAllowed p = true ∧ withinBounds (p, g, b, e, a) = true →
     nclose specN ⊆ E →

     spec_ctx ∗ ⤇ fill K (Instr Executable)
              ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
              ∗ ▷ pc_a ↣ₐ w
              ∗ ▷ dst ↣ᵣ inr (p,g,b,e,a)
              ∗ ▷ a ↣ₐ w'
     ={E}=∗ ⤇ fill K (Instr NextI)
         ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
         ∗ pc_a ↣ₐ w
         ∗ dst ↣ᵣ inr (p,g,b,e,a)
         ∗ a ↣ₐ inl z.
  Proof.
    iIntros (Hinstr Hvpc Hpca' [Hwa Hwb] Hnclose)
            "(Hown & Hj & >HPC & >Hi & >Hdst & >Hsrca)".
    iDestruct (rules_binary_base.map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iDestruct (spec_memMap_resource_2ne_apply with "Hi Hsrca") as "[Hmem %]"; auto.

    iMod (step_store _ _ pc_p with "[$Hown $Hj $Hmap $Hmem]") as (retv regs' mem' Hspec) "(Hj & Hmem & Hregs)";
      eauto; simplify_map_eq_alt; try rewrite lookup_insert; eauto.
    { by rewrite !dom_insert; set_solver+. }
    { eapply mem_neq_implies_allow_store_map with (a := a); eauto.
      rewrite lookup_insert_ne// lookup_insert. eauto. }

    destruct Hspec.
     { (* Success *)
       iFrame.
       destruct H5 as [Hrr2 _]. simplify_map_eq_alt.
       rewrite insert_commute // insert_insert.
       iDestruct (rules_binary_base.memMap_resource_2ne with "Hmem") as "[Hpc_a Ha]";auto.
       incrementPC_inv. simpl in *.
       simplify_map_eq_alt.
       rewrite insert_insert.
       iDestruct (rules_binary_base.regs_of_map_2 with "[$Hregs]") as "[HPC Hdst]"; eauto. by iFrame. }
     { (* Failure (contradiction) *)
       destruct X; simplify_map_eq_alt.
       destruct o. all: try congruence. inversion e2. subst. rewrite /canStore in e3. congruence.
       incrementPC_inv;[|rewrite lookup_insert;eauto].
       destruct e0; try congruence. inv Hvpc; naive_solver.
     }
  Qed.

End cap_lang_spec_rules.