From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Import model_update_prelude model_lst
     model_gst model_update_lhst model_update_lst.

Section Gst_update.
  Context `{!anerisG Mdl Σ, !DB_params}.

   (** Global and local state coherence *)

  Lemma DBM_gs_ls_coh (i: nat) (gs : Gst) (ls : Lst) :
    i < length DB_addresses →
    DBM_Gst_valid gs →
    DBM_Lst_valid i ls →
    gs.(Gst_hst) !! i = Some ls.(Lst_hst) →
    dom ls.(Lst_mem) ⊆ dom gs.(Gst_mem) ∧
    ∀ k v, k ∈ DB_keys → ls.(Lst_mem) !! k = Some v →
           ∃ a h, gs.(Gst_mem) !! k = Some h ∧ a ∈ h ∧ a.(we_val) = v.
  Proof.
    intros.
    split.
    {  erewrite DBM_GstValid_dom; last done; by eapply DBM_LSTV_dom_keys. }
    intros k v Hk Hkv.
    eapply DBM_LSTV_vals_Some in Hkv as [Hv1 Hkv2]; eauto.
    set (Observe_lhst (restrict_key k (Lst_hst ls))) as e in *.
    apply compute_maximals_correct in Hkv2 as ([He Hem2]%elem_of_filter & Hem').
    eapply DBM_GV_hst_in_mem in Hem2 as (h & Hh & Heh);
      eauto using elem_of_list_lookup_2.
    simplify_eq/=.
    eexists (erase e), h; split_and!;
      [by rewrite -He|done|by rewrite -erase_val].
  Qed.

Lemma DBM_mem_dom_update {A: Type} k (v : A) (d: gmap Key A) :
    k ∈ DB_keys →
    dom d = DB_keys →
    dom (<[k:=v]> d) = DB_keys.
  Proof. by set_solver. Qed.

  Lemma DBM_gs_hst_valid_update gs i s m:
    DBM_Gst_valid gs →
    DBM_lhst_valid i s →
    DBM_gs_hst_valid
      {| Gst_mem := m; Gst_hst := <[i:=s]> (Gst_hst gs) |}.
  Proof.
    intros Hgv Hsv j sj Hgs; simpl.
    destruct (decide (j = i)) as [-> | ].
    - rewrite list_lookup_insert in Hgs.
      + by simplify_eq.
      + pose proof (DBM_GV_hst_size Hgv).
        epose proof DBM_LHV_bound_at.
        erewrite (DBM_GV_hst_size Hgv); eauto.
    - rewrite list_lookup_insert_ne in Hgs; last done.
      eapply DBM_GV_hst_lst_valid; eauto.
  Qed.

Lemma DBM_gs_hst_size_update gs i s m:
    DBM_Gst_valid gs →
    DBM_gs_hst_size
      {| Gst_mem := m; Gst_hst := <[i:=s]> (Gst_hst gs) |}.
  Proof.
    intros Hgv. rewrite /DBM_gs_hst_size //=.
    rewrite insert_length.
    by eapply DBM_GV_hst_size.
  Qed.

  Lemma DBM_system_write_update_gst
        (k : Key) (v : val) (i : nat) (gs : Gst) (ls : Lst) mk :
    k ∈ DB_keys →
    DBM_Lst_valid i ls →
    DBM_Gst_valid gs →
    gs.(Gst_hst) !! i = Some ls.(Lst_hst) →
    gs.(Gst_mem) !! k = Some mk →
    let t := incr_time ls.(Lst_time) i  in
    let e := ApplyEvent k v t i (S (size ls.(Lst_hst))) in
    let s := ls.(Lst_hst) ∪ {[ e ]} in
    let m := (<[ k := mk ∪ {[erase e]} ]> gs.(Gst_mem)) in
    let Ss := <[i := s]> gs.(Gst_hst) in
    DBM_Gst_valid (GST m Ss).
   Proof.
    intros Hk Hvl Hvg Hgs Hgm t e s m Ss.
    pose proof (DBM_LSTV_at Hvl) as Hi.
    pose proof DBM_LSTV_hst_valid Hvl as Hvlh.
    assert (update_condition i e (Lst_time ls)) as Hcond.
    eapply update_condition_write; eauto.
    pose proof Hcond as
            (Hi' & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
    split.
    - by eapply DBM_mem_dom_update; eauto; eapply DBM_GV_dom.
    - eapply DBM_gs_hst_size_update; eauto.
    - eapply DBM_gs_hst_valid_update; eauto.
      rewrite /DBM_lst_hst_valid in Hvlh.
      eapply DBM_lhst_update.
      + eauto.
      + eauto.
      + eauto.
      + eauto using DBM_Lst_valid_time_le; eauto.
      + rewrite (DBM_LSTV_time Hvl (ae_orig e) Heorig).
        symmetry.
        pose proof (lsec_lsup_length (ae_orig e)); eauto.
      + intros ? j0 Hj0.
        rewrite (DBM_LSTV_time Hvl j0 Hj0).
        symmetry.
        pose proof (lsec_lsup_length (ae_orig e)); eauto.
      + intros j0 Hj0.
        rewrite (DBM_LSTV_time Hvl j0 Hj0).
        pose proof (lsec_lsup_length
                      i j0 (Lst_hst ls) Hvlh Hj0)
          as Hll. rewrite Hll.
        eauto with lia.
    - intros s1 Hs1 e1 He1. simpl in Hs1.
      subst Ss. apply elem_of_list_lookup in Hs1 as (j & Hs1).
      destruct (decide (i = j)) as [<-|Hneqij].
      + rewrite list_lookup_insert in Hs1. inversion Hs1. subst s1.
        clear Hs1. apply elem_of_union in He1 as [He1|?%elem_of_singleton_1].
        * destruct (λ H, DBM_GV_hst_in_mem Hvg (Lst_hst ls) H e1)
            as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
          destruct (decide (k = ae_key e1)) as [->|Hneq].
          ** subst m; setoid_rewrite lookup_insert.
             exists (mk ∪ {[erase e]}); split; first done.
             rewrite Hgm // in Hh'. set_solver.
          ** subst m; setoid_rewrite lookup_insert_ne; last done.
             eexists; eauto.
        * simpl. subst e1 m.
          assert (k = ae_key e) as <- by eauto.
          setoid_rewrite lookup_insert.
          exists (mk ∪ {[erase e]}); split; first done.
          set_solver.
        * rewrite (DBM_GV_hst_size Hvg) //.
      + rewrite list_lookup_insert_ne in Hs1.
        destruct (λ H, DBM_GV_hst_in_mem Hvg s1 H e1)
          as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
        destruct (decide (k = ae_key e1)) as [->|Hneq]; simpl.
        * subst m.
          setoid_rewrite lookup_insert.
          rewrite Hh' in Hgm.
          eexists _. split_and!; eauto with set_solver.
        * exists h'; split_and!; eauto.
          by rewrite lookup_insert_ne; last done.
        * done.
    - intros a h Hm Hah.
      subst m Ss s. simpl in Hm. simpl.
      destruct (decide ((we_key a) = k)) as [ <- | Hneq0 ].
      + rewrite lookup_insert in Hm.
        simplify_eq.
        apply elem_of_union in Hah as[ Hamk| Ha1%elem_of_singleton_1].
        * destruct (DBM_GV_mem_in_hst Hvg a mk Hgm Hamk)
            as (sa & saa & ea & Hsa & Hsaa & Hea & Hear).
          destruct (decide (i = we_orig a)) as [Heq|Hneq].
          ** eexists (Lst_hst ls ∪ {[e]}), (saa ∪ {[e]}), ea.
             split_and!.
             *** subst; rewrite list_lookup_insert; first done.
                 rewrite (DBM_GV_hst_size Hvg) //.
             *** subst; rewrite //. set_solver.
             *** set_solver.
             *** done.
          ** eexists _, _, _.
             split_and!; eauto.
             by rewrite list_lookup_insert_ne.
        * eexists _, _, e.
          split_and!; eauto.
          ** rewrite Ha1. rewrite list_lookup_insert //=.
             rewrite (DBM_GV_hst_size Hvg) //.
          ** rewrite DBM_lsec_union DBM_lsec_singleton_in.
             *** set_solver.
             *** by rewrite Ha1.
      + rewrite lookup_insert_ne //= in Hm.
        destruct (decide (i = we_orig a)) as [Heq|Hneq].
       * assert
         (∃ (s0 si : gset apply_event) (e0 : apply_event),
             Gst_hst gs !! we_orig a =
             Some s0 ∧ DBM_lsec (we_orig a) s0 = si
             ∧ e0 ∈ si ∧ erase e0 = a)
           as (s0 & si & e0 & Hs0 & Hs1 & Hs2 & Hs3)
             by by eapply DBM_GV_mem_in_hst.
         rewrite -!Heq. rewrite -!Heq in Hs0 Hs1.
         rewrite list_lookup_insert.
         ** do 3 eexists. repeat split; eauto.
           rewrite /s0. set_solver.
         ** eapply lookup_lt_is_Some_1; eauto.
       * rewrite //=.
         simpl in Hm.
         rewrite list_lookup_insert_ne; eauto.
         eapply DBM_GV_mem_in_hst; eauto.
    - intros k1 h1 a1 Hh1 Ha1.
      rewrite /m //= in Hh1.
      destruct (decide (k1 = k)) as [-> | ].
      + rewrite lookup_insert //= in Hh1.
        simplify_eq.
        apply elem_of_union in Ha1 as [| ?%elem_of_singleton_1];
          [|set_solver].
        eapply DBM_GV_mem_elements_key; eauto.
      + rewrite lookup_insert_ne //= in Hh1.
        eapply DBM_GV_mem_elements_key; eauto.
   Qed.

   Lemma DBM_system_apply_update_gst
        (i : nat) (gs : Gst) (ls : Lst)
        (a : write_event) (h: gset write_event) :
    DBM_Gst_valid gs →
    DBM_Lst_valid i ls →
    gs.(Gst_hst) !! i = Some ls.(Lst_hst) →
    gs.(Gst_mem) !! a.(we_key) = Some h →
    a ∈ h →
    a.(we_orig) ≠ i →
    let t := incr_time ls.(Lst_time) a.(we_orig) in
    let e := ApplyEvent (we_key a) (we_val a) (we_time a) (we_orig a)
                        (S (size ls.(Lst_hst))) in
    let s := ls.(Lst_hst) ∪ {[ e ]} in
    let d := (<[ a.(we_key) := a.(we_val) ]> ls.(Lst_mem)) in
    let Ss := (<[i := s]> gs.(Gst_hst)) in
    update_condition i e ls.(Lst_time) →
    DBM_Gst_valid (GST gs.(Gst_mem) Ss).
   Proof.
     intros Hvg Hvl Hgsi ?????????.
     split.
     - apply (DBM_GV_dom Hvg); eauto.
     - eapply DBM_gs_hst_size_update; eauto.
     - eapply DBM_gs_hst_valid_update; eauto.
       assert (DBM_Lst_valid i {|Lst_mem := d; Lst_time := t; Lst_hst := s|})
         as Hvlst.
       { apply (DBM_lst_update e i ls Hvl); eauto. }
       eapply (DBM_LSTV_hst_valid Hvlst).
     - intros s1 Hs1 e1 He1. simpl in Hs1.
       subst Ss. apply elem_of_list_lookup in Hs1 as (j & Hs1).
      destruct (decide (i = j)) as [<-|Hneqij].
      + rewrite list_lookup_insert in Hs1. inversion Hs1. subst s1.
        clear Hs1. apply elem_of_union in He1 as [He1|?%elem_of_singleton_1].
        * destruct (λ H, DBM_GV_hst_in_mem Hvg (Lst_hst ls) H e1)
            as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
        * simpl. subst e1.
          assert (a = erase e) as <- by by destruct a.
          eauto.
        * rewrite (DBM_GV_hst_size Hvg)  //.
          by eapply DBM_LSTV_at.
      + rewrite list_lookup_insert_ne in Hs1.
        destruct (λ H, DBM_GV_hst_in_mem Hvg s1 H e1)
          as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
        done.
     - intros a1 h1 Hm Ha1.
       destruct (decide (i = we_orig a1)) as [Heq|Hneq].
       + assert
         (∃ (s0 si : gset apply_event) (e0 : apply_event),
             Gst_hst gs !! we_orig a1 =
             Some s0 ∧ DBM_lsec (we_orig a1) s0 = si
             ∧ e0 ∈ si ∧ erase e0 = a1)
           as (s0 & si & e0 & Hs0 & Hs1 & Hs2 & Hs3)
             by by eapply DBM_GV_mem_in_hst.
         rewrite -!Heq. rewrite -!Heq in Hs0 Hs1.
         rewrite list_lookup_insert.
         * do 3 eexists. repeat split; eauto.
           rewrite /s. set_solver.
         * eapply lookup_lt_is_Some_1; eauto.
       + rewrite /Ss //=.
         simpl in Hm.
         rewrite list_lookup_insert_ne; eauto.
         eapply DBM_GV_mem_in_hst; eauto.
     - rewrite /DBM_gs_gmem_elements_key /=.
       eapply DBM_GV_mem_elements_key; eauto.
   Qed.

End Gst_update.


(**
Creates functorial lemmas that the parametricity translation
behaves like a functor in respect to its parameters

Application: When proving the induction lemma,
one encounters the problem that the parametricity translation argument
listᵗ rose roseᵗ H is given stating that the property roseᵗ holds for all rose
trees in the list. But we want the nested inductive hypothesis
listᵗ rose P H that the property P under consideration in the induction
holds for all trees in the list.
Therefore, we need to translate the proofs of roseᵗ to P.
This is possible for two reasons:
* The inductive proof transforms roseᵗ instances into proofs of P
    (we state that P holds for all roseᵗ)
* Secondly, the parametricity translation of a container simply boundles
    all proofs for the elements in it.
  Therefore, all proofs can be replaced for another property, and thus,
  the parametricity translation of a container behaves like a functor.

Note: The substitution of P for roseᵗ makes it clear why
    the induction does not carry the roseᵗ instances in the predicate
    as such handling for nested types would no longer be possible.
    Additionally, the generates lemma is less cluttered as it is ultimately
    a lemma for rose not roseᵗ.

example:
listᵗ A Aᵗ x
with A:Type, Aᵗ:A->Type, x:list A

the functorial lemma has type:
∀ A (Aᵗ:A->Type) (Aᵗ':A->Type) (F_A: ∀ (a:A), Aᵗ a -> Aᵗ' a)
(x:list A),
listᵗ A Aᵗ x -> listᵗ A Aᵗ' x

Note:
A->Type can be viewed as (Typeᵗ A)

For each pair of parameter and translation another translation as destination
is introduced together with a function stating the translation property for this paramter.
This property will be recursively instantiated in the proofs.
If the parameter has no arguments or does not result in a sort, a dummy value like True
is introduced as each parametricity translated argument contains the same information.

The indices contain no further information needed to be transferred between instances.
They do not possess a functorial nature as they are dictated by inversion.
Therefore, they are carried over.
A special indice is the instance of the original type (list in the example above).
But this instance does not need any special care.

*)
Require Import util.

From MetaCoq.Template Require Import All.

From MetaCoq Require Import All.
Require Import String List.
(* Local Open Scope string. *)
Import ListNotations Nat.
Import MCMonadNotation.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import TemplateToPCUIC.
From MetaCoq.PCUIC Require Import PCUICToTemplate.

Section Functorial.

    Variable
        (inductive:inductive)
        (uinst:Instance.t)
        (mind:mutual_inductive_body)
        (ind:one_inductive_body).

    Definition ind_term := tInd inductive uinst.

    Definition non_uniform_param_count := 0. (* should not matter here *)
    Definition ind_type := ind.(ind_type). (* type of the inductive *)
    Definition ctx_retTy := decompose_prod_assum [] ind_type. (* get params and indices and inner retTy *)
    Definition ctx := ctx_retTy.1.
    Definition retTy := ctx_retTy.2.
        (* for list: ctx=[Type], retTy=Type *)
    Definition indice_ctx := ind_indices ind.
    Definition all_param_ctx := skipn #|indice_ctx| ctx. (* parameters and non-uniform parameter *)
    Definition non_uni_param_ctx := firstn non_uniform_param_count all_param_ctx. (* non-uniform are behind => at the front *)
    Definition param_ctx := skipn #|non_uni_param_ctx| all_param_ctx.

    Definition TrueQ :=
        TemplateToPCUIC.trans [] <% True %>.

    (*
    given an argument Aᵗ generates the functorial property term
    for ∀, copy the binder and remember to apply the arguments
    for Sort, generate Aᵗ args -> Aᵗ' args
    Otherwise generate True
     *)
        (* this is something like parametricity itself *)
    Fixpoint func x y args t :=
        match t with
        | tSort univ =>
            tProd rAnon (mkApps x args) (mkApps (lift0 1 y) (map (lift0 1) args))
        | tProd na a b =>
            tProd na a (
                func (lift0 1 x) (lift0 1 y) (map (lift0 1) args ++ [tRel 0]) b
            )
        | _ => TrueQ
        end.

    Definition app_arg_list num args := map (fun x => x+num) args++mkNums num.

    (* no context but list of params *)
    (*
    for params A, Aᵗ add Aᵗ' and F_A
    takes list of param applications for the original and transformed term
    returns the number of parameter groups, the list of argument applications
    as number for the binder and lastly the list of new arguments (params & indices)
     *)
    Fixpoint augment (params:context) (arg1 arg2:list nat):=
        match params with
        | x::xᵗ::xr =>
            let '((groups,arg1,arg2), aug_args) :=
                augment xr
                    (map (fun x => x+4) arg1++[3;2])
                    (map (fun x => x+4) arg2++[3;1]) in
                ((S groups, arg1,arg2),
                    x::xᵗ::
                    (map_decl (lift0 1) xᵗ)::
                    (vass rAnon (func (tRel 1) (tRel 0) [] (lift0 2 xᵗ.(decl_type))))::
                    (mapi (fun i a => map_decl (lift 2 i) a) aug_args))
        | _ =>
        let indices := rev (indice_ctx) in
        ((0,
            app_arg_list (#|params|+#|indices|) arg1,
            app_arg_list (#|params|+#|indices|) arg2),params++indices)
        end.

        (* computes number of param groups and type of the functorial property *)
    Definition type_ :=
        let '((groups,arg1,arg2),aug_args) := augment (rev param_ctx) [] [] in
        let aug_args_ctx := rev (aug_args) in
        (groups,
        it_mkProd_or_LetIn
            aug_args_ctx
        (tProd rAnon
        (mkApps ind_term (map tRel arg1))
        (lift0 1 (mkApps ind_term (map tRel arg2)))
        ))
        .

    Definition functorial_type_groups :=
        on_snd PCUICToTemplate.trans type_.

    Definition type := snd type_.

    Definition functorial_type :=
    PCUICToTemplate.trans type.

    (*
    Generation of the functorial property
    currently, the properties are only realized
    using obligations
     *)
    (* Definition functorial :=
    tCast
    (PCUICToTemplate.trans
        placeholder
        (* (it_mkLambda_or_LetIn
        lemma_argument_ctx
        ) *)
    )
    Cast
    (PCUICToTemplate.trans type). *)

End Functorial.

Ltac ind_on_last :=
  lazymatch goal with
  | |- forall x y, ?H => intros ?;ind_on_last
  | |- forall y, ?H =>
      let inst := fresh "x" in
      intros inst;induction inst (* using database *)
  | _ => fail "not applicable"
  end.
Global Obligation Tactic := cbn;ind_on_last;econstructor;auto.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.message.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* This program, and its verification, are described in Chapter 29
   of _Program Logics for Certified Compilers_, by Appel et al., 2014 *)

Local Open Scope Z.
Local Open Scope logic.

(*   mf_assert msgfmt sh buf len data  := the [data] is formatted into a message
         at most [len] bytes,  stored starting at address [buf] with share [sh] *)

Record message_format (t: type) : Type :=
mf_build {
   mf_size: Z;
   mf_data_assert: forall (data: reptype t), Prop;
   mf_assert: forall (sh: share) (buf: val) (len: Z) (data: reptype t), mpred;
   mf_size_range:  0 <= mf_size <= Int.max_signed;
   mf_bufprop: forall sh buf len data,
           mf_assert sh buf len data |--
                 !!(0 <= len <= mf_size) && memory_block sh len buf;
   mf_restbuf := fun (sh: share) (buf: val) (len: Z) =>
          memory_block sh (mf_size-len) (offset_val len buf)
}.

Arguments mf_build {t}.
Arguments mf_size {t}.
Arguments mf_data_assert {t}.
Arguments mf_assert {t}.
Arguments mf_bufprop {t}.
Arguments mf_size_range {t}.
Arguments mf_restbuf {t}.

Lemma mf_assert_local_facts: forall t (mf: message_format t) sh buf len (data: reptype t),
   mf_assert mf sh buf len data |--
    !! (0 <= len <= mf_size mf /\ isptr buf).
Proof.
intros.
eapply derives_trans;[ apply mf_bufprop | ].
entailer!.
Qed.

#[export] Hint Resolve mf_assert_local_facts : saturate_local.

Definition t_struct_intpair := Tstruct _intpair noattr.
Definition t_struct_message := Tstruct _message noattr.

Program Definition intpair_message: message_format t_struct_intpair :=
  mf_build 8 (fun data => is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
             (fun sh buf len data => !!(len=8/\ is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
                           && data_at sh (tarray tint 2) [fst data; snd data] buf)
      _ _.
Next Obligation.
compute; split; congruence.
Qed.
Next Obligation.
  entailer!!.
  change 8 with (sizeof (tarray tint 2)).
  apply data_at_memory_block.
Qed.

Definition serialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share
  PRE [ tptr tvoid, tptr tuchar ]
          PROP (readable_share sh; writable_share sh';
                mf_data_assert format data;
                align_compatible tint buf)
          PARAMS (p; buf)
          SEP (data_at sh t data p;
                 memory_block sh' (mf_size format) buf)
  POST [ tint ]
         EX len: Z,
          PROP() RETURN (Vint (Int.repr len))
          SEP( data_at sh t data p;
                 mf_assert format sh' buf len data;
                 mf_restbuf format sh' buf len).

Definition deserialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share, len: Z
  PRE [ tptr tvoid, tptr tuchar, tint ]
          PROP (readable_share sh'; writable_share sh;
                0 <= len <= mf_size format)
          PARAMS (p; buf; Vint (Int.repr len))
          SEP (mf_assert format sh' buf len data;
                 data_at_ sh t p)
  POST [ tvoid ]
          PROP (mf_data_assert format data)  RETURN ()
          SEP (mf_assert format sh' buf len data;
                 data_at sh t data p).

Definition intpair_serialize_spec :=
 DECLARE _intpair_serialize (serialize_spec intpair_message).

Definition intpair_deserialize_spec :=
 DECLARE _intpair_deserialize (deserialize_spec intpair_message).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition message (sh: share) {t: type} (format: message_format t) (m: val) : mpred :=
  EX fg: val*val,
          func_ptr' (serialize_spec format) (fst fg) *
          func_ptr' (deserialize_spec format) (snd fg) *
       data_at sh t_struct_message (Vint (Int.repr (mf_size format)), (fst fg, snd fg)) m.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    intpair_serialize_spec; intpair_deserialize_spec; main_spec]).

Lemma body_intpair_serialize: semax_body Vprog Gprog f_intpair_serialize intpair_serialize_spec.
Proof.
unfold intpair_serialize_spec.
unfold serialize_spec.
start_function.
destruct H as [Dx Dy].
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction. clear Dx Dy.

change (mf_size intpair_message) with (sizeof (tarray tint 2)).
assert_PROP (field_compatible (tarray tint 2) [] buf).
  entailer!.
  hnf in H; decompose[and] H; repeat split; auto.
  (* TODO: abstract the following proof. *)
  unfold align_compatible in H0 |- *.
  destruct buf; auto.
  constructor.
  intros.
  eapply align_compatible_rec_by_value_inv in H0; [| reflexivity].
  econstructor; [reflexivity |].
  apply Z.divide_add_r; auto.
  exists i0; rewrite Z.mul_comm; auto.
rewrite memory_block_data_at_; auto.
change (data_at_ sh' (tarray tint 2) buf) with
   (data_at sh' (tarray tint 2) [Vundef;Vundef] buf).
forward. (* x = p->x; *)
forward. (* y = p->y; *)
forward. (*  ((int * )buf)[0]=x; *)
forward. (*  ((int * )buf)[1]=y; *)
forward. (* return 8; *)
Exists 8.
unfold mf_restbuf. simpl.
rewrite memory_block_zero.
entailer!!.
Qed.

Lemma body_intpair_deserialize: semax_body Vprog Gprog f_intpair_deserialize intpair_deserialize_spec.
Proof.
unfold intpair_deserialize_spec, deserialize_spec.
start_function.
hnf in data; simpl in data. (* This speeds things up dramatically *)
simpl. Intros. subst len.
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction.
clear H H1 H2.
forward. (* x = ((int * )buf)[0]; *)
forward. (* y = ((int * )buf)[1]; *)
forward. (* p->x = x; *)
forward. (* p->y = y; *)
entailer!.
split; simpl; auto.
unfold mf_assert.
simpl.
entailer!!.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
function_pointers.
start_function.
set (ipm := gv _intpair_message).
fold cc_default noattr.
make_func_ptr _intpair_deserialize.
make_func_ptr _intpair_serialize.
set (des := gv _intpair_deserialize).
set (ser := gv _intpair_serialize).
match goal with
 |- context [mapsto_zeros 4 Ews _] =>
  (* 64-bit mode *)
  sep_apply mapsto_zeros_memory_block; auto;
  gather_SEP (mapsto _ _ _ (offset_val 0 des))
      (mapsto _ _ _ (offset_val 0 ser))
      (memory_block Ews 4 _)
      (data_at _ _ _ ipm)
 | _ => (*32-bit mode *)
  gather_SEP (mapsto _ _ _ (offset_val 0 des))
      (mapsto _ _ _ (offset_val 0 ser))
      (data_at _ _ _ ipm)
end.
replace_SEP 0
    (data_at Ews t_struct_message
      (Vint (Int.repr (mf_size intpair_message)), (ser, des)) ipm). {
 entailer!.
 unfold_data_at (data_at _ t_struct_message _ ipm).
 rewrite (field_at_data_at _ _ _ _ ipm).
rewrite data_at_tuint_tint.
(* rewrite <- (mapsto_field_at _ _ [StructField _bufsize] (Vint (Int.repr 8))) by auto with field_compatible. *)
 rewrite <- (mapsto_field_at _ _ [StructField _deserialize] des) by auto with field_compatible.
 rewrite <- (mapsto_field_at _ _ [StructField _serialize] ser) by auto with field_compatible.
 rewrite !field_compatible_field_address by auto with field_compatible.
 simpl.
 normalize.
 unfold spacer, at_offset; simpl.
 cancel.
}
forward. (* p.x = 1; *)
forward. (* p.y = 2; *)
forward. (* ser = intpair_message.serialize; *)

rewrite <- memory_block_data_at__tarray_tuchar_eq by computable.
change (memory_block Tsh 8 v_buf)
with (memory_block Tsh (mf_size intpair_message) v_buf).

assert_PROP (align_compatible tint v_buf).
  entailer!.
  destruct HPv_buf; subst; simpl.
  econstructor; [reflexivity | apply Z.divide_0_r].
forward_call (* len = ser(&p, buf); *)
      ((Vint (Int.repr 1), Vint (Int.repr 2)), v_p, v_buf, Tsh, Tsh).
  split3; auto.
  repeat split; auto.
Intros rest.
simpl.
Intros. subst rest.

forward. (* des = intpair_message.deserialize; *)
forward_call (* des(&q, buf, 8); *)
        ((Vint (Int.repr 1), Vint (Int.repr 2)), v_q, v_buf, Tsh, Tsh, 8).
  simpl. fold t_struct_intpair. entailer!.
  simpl; computable.
(* after the call *)
forward. (* x = q.x; *)
forward. (* y = q.y; *)
forward. (* return x+y; *)
simpl.
entailer!.
sep_apply (data_at_memory_block Tsh (tarray tint 2) [Vint (Int.repr 1); Vint (Int.repr 2)] v_buf).
unfold sizeof; simpl Ctypes.sizeof.
sep_apply (memory_block_data_at__tarray_tuchar Tsh v_buf 8).
   computable.
entailer!!.
Qed.


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 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.