Require Export
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations
        Fiat.QueryStructure.Specification.Operations.Query.
Require Import Coq.Lists.List
        Coq.Arith.Compare_dec
        Coq.Bool.Bool
        Coq.Strings.String
        Fiat.Common.BoolFacts
        Fiat.Common.List.PermutationFacts
        Fiat.Common.List.ListMorphisms
        Fiat.QueryStructure.Specification.Operations.FlattenCompList
        Fiat.Common.Ensembles.EnsembleListEquivalence
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.Common.IterateBoundedIndex
        Fiat.Common.List.ListFacts
        Fiat.Common.LogicFacts
        Fiat.Common.DecideableEnsembles
        Fiat.Computation.Refinements.Iterate_Decide_Comp
        Fiat.Computation.Refinements.General
        Fiat.QueryStructure.Specification.Constraints.tupleAgree
        Fiat.QueryStructure.Specification.Operations.Mutate.

Import Lists.List.ListNotations.

Unset Implicit Arguments.

Local Transparent Count Query_For.

Section ConstraintCheckRefinements.
  Hint Resolve crossConstr : core
  Hint Unfold SatisfiesCrossRelationConstraints
       SatisfiesAttributeConstraints
       SatisfiesTupleConstraints.

  Fixpoint List_Query_eqT
           (attrlist : list Type)
    : Type
    := match attrlist with
       | [ ] => unit
       | attr :: attrlist' =>
         prod (Query_eq attr) (List_Query_eqT attrlist')
       end.

  Fixpoint Tuple_Agree_eq'
           {h : RawHeading}
           {attrlist : list (Attributes h)}
           (attr_eq_dec : List_Query_eqT (map (Domain h) attrlist))
           (tup tup' : @RawTuple h)
    : bool :=
    match attrlist return List_Query_eqT (map (Domain h) attrlist) ->
                          bool with
    | [ ] => fun _ => true
    |  attr :: attrlist' =>
       fun attr_eq_dec' =>
         if @A_eq_dec _ (fst attr_eq_dec') (GetAttributeRaw tup attr) (GetAttributeRaw tup' attr)
         then Tuple_Agree_eq' (snd attr_eq_dec') tup tup'
         else false
    end attr_eq_dec.

  Class List_Query_eq (As : list Type) :=
    { As_Query_eq : List_Query_eqT As}.

  Definition Tuple_Agree_eq {h} (attrlist : list (Attributes h))
          (attr_eq_dec : List_Query_eq (map (Domain h) attrlist)) tup tup' :=
    @Tuple_Agree_eq' h attrlist (@As_Query_eq _ attr_eq_dec) tup tup'.

  Lemma Tuple_Agree_eq_dec h attrlist attr_eq_dec (tup tup' : @RawTuple h) :
    tupleAgree tup tup' attrlist <->
    Tuple_Agree_eq attrlist attr_eq_dec tup tup' = true.
  Proof.
    destruct attr_eq_dec.
    induction attrlist; unfold tupleAgree in *; simpl in *; simpl;
    intuition;
    unfold Tuple_Agree_eq in *; simpl in *; find_if_inside; simpl; subst; eauto;
    try (eapply IHattrlist; eauto; fail);
    discriminate.
  Qed.

  Lemma Tuple_Agree_eq_dec' h attrlist attr_eq_dec (tup tup' : @RawTuple h) :
    ~ tupleAgree tup tup' attrlist <->
    Tuple_Agree_eq attrlist attr_eq_dec tup tup' = false.
  Proof.
    destruct attr_eq_dec.
    induction attrlist; unfold tupleAgree in *; simpl in *; simpl;
    intuition;
    unfold Tuple_Agree_eq in *; simpl in *; intuition;
    find_if_inside; simpl; subst; eauto.
    try (eapply IHattrlist; intros; eapply H).
    intros; intuition; subst; auto.
    eapply IHattrlist; intros; eauto.
  Qed.

  Definition Tuple_Agree_dec h attrlist
             (attr_eq_dec : List_Query_eq (map (Domain h) attrlist)) (tup tup' : @RawTuple h)
    : {tupleAgree tup tup' attrlist} + {~ tupleAgree tup tup' attrlist}.
  Proof.
    case_eq (Tuple_Agree_eq attrlist attr_eq_dec tup tup').
    left; eapply Tuple_Agree_eq_dec; eauto.
    right; eapply Tuple_Agree_eq_dec'; eauto.
  Defined.

  Lemma tupleAgree_sym :
    forall (heading: Heading) tup1 tup2 attrs,
      @tupleAgree heading tup1 tup2 attrs <-> @tupleAgree heading tup2 tup1 attrs.
  Proof.
    intros; unfold tupleAgree;
    split; intros; rewrite H; eauto.
  Qed.

  (* Consequences of ith_replace_BoundIndex_neq and ith_replace_BoundIndex_eq on updates *)

  Lemma refine_SatisfiesAttributeConstraints_self
    : forall (qsSchema : RawQueryStructureSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b (SatisfiesAttributeConstraints Ridx tup )}
             match (attrConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr => {b | decides b (Constr tup) }
             | None => ret true
             end.
  Proof.
    unfold SatisfiesAttributeConstraints.
    intros; match goal with
              |- context [attrConstraints ?A] => destruct (attrConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
  Qed.

  Lemma refine_SatisfiesTupleConstraints_self
    : forall (qsSchema : RawQueryStructureSchema)
             (Ridx : Fin.t _)
             (tup tup' : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b (SatisfiesTupleConstraints Ridx tup tup')}
             match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr => {b | decides b (Constr tup tup') }
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
  Qed.

  Lemma refine_SatisfiesTupleConstraints_Constr
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides
                    b
                    (forall tup',
                        GetRelation qs Ridx tup'
                        -> SatisfiesTupleConstraints
                             Ridx
                             tup
                             (indexedElement tup'))}
             match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetRelation qs Ridx tup'
                                  -> Constr tup (indexedElement tup'))}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesTupleConstraints_Constr'
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b
                          (forall tup',
                              GetRelation qs Ridx tup'
                              -> SatisfiesTupleConstraints Ridx (indexedElement tup') tup)}
             match tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetRelation qs Ridx tup'
                                  -> Constr (indexedElement tup') tup)}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesCrossConstraints_Constr
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                                 SatisfiesCrossRelationConstraints
                                   Ridx Ridx' tup
                                   (GetRelation qs Ridx')))
        (@Iterate_Decide_Comp_opt _ (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                      | Some CrossConstr =>
                                        Some (CrossConstr tup (GetRelation qs Ridx'))
                                      | None => None
                                      end)) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma refine_SatisfiesTupleConstraints
    : forall (qsSchema : RawQueryStructureSchema)
             (qs : UnConstrQueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides
                    b
                    (forall tup',
                        GetUnConstrRelation qs Ridx tup'
                        -> SatisfiesTupleConstraints
                             Ridx
                             tup
                             (indexedElement tup'))}
             match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _)) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetUnConstrRelation qs Ridx tup'
                                  -> Constr tup (indexedElement tup'))}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesTupleConstraints'
    : forall (qsSchema : RawQueryStructureSchema)
             (qs : UnConstrQueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine {b | decides b
                          (forall tup',
                              GetUnConstrRelation qs Ridx tup'
                              -> SatisfiesTupleConstraints Ridx (indexedElement tup') tup)}
             match tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) _) with
               Some Constr =>
               {b | decides b (forall tup',
                                  GetUnConstrRelation qs Ridx tup'
                                  -> Constr (indexedElement tup') tup)}
             | None => ret true
             end.
  Proof.
    unfold SatisfiesTupleConstraints.
    intros; match goal with
              |- context [tupleConstraints ?A] => destruct (tupleConstraints A)
            end;
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesCrossConstraints
    : forall (qsSchema : RawQueryStructureSchema)
             (qs : UnConstrQueryStructure qsSchema)
             (Ridx : Fin.t _)
             (tup : @RawTuple (rawSchemaHeading (GetNRelSchema (qschemaSchemas qsSchema) Ridx))),
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                                 SatisfiesCrossRelationConstraints
                                   Ridx Ridx' tup
                                   (GetUnConstrRelation qs Ridx')))
        (@Iterate_Decide_Comp_opt _ (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                      | Some CrossConstr =>
                                        Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                      | None => None
                                      end)) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma refine_SatisfiesCrossConstraints'_Constr
    : forall (qsSchema : QueryStructureSchema)
             (qs : QueryStructure qsSchema)
             (Ridx : Fin.t _)
             tup idx,
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                Ridx' <> Ridx
                -> forall tup',
                     (GetRelation qs Ridx') tup'
                     -> SatisfiesCrossRelationConstraints
                          Ridx' Ridx (indexedElement tup')
                          (EnsembleInsert
                             {| elementIndex := idx;
                                indexedElement := tup |}
                             (GetRelation qs Ridx))))
             (@Iterate_Decide_Comp_opt _
                                        (fun Ridx' =>
                                           if (fin_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedElement tup') (
                                                                        (EnsembleInsert
                                                                           {| elementIndex := idx;
                                                                              indexedElement := tup |}
                                                                           (GetRelation qs Ridx))))
                                               | None => None
                                      end)).
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints.
    apply refine_Iterate_Decide_Comp_equiv; simpl; intros.
    simpl in *; destruct (fin_eq_dec Ridx idx0); subst.
    congruence.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
    simpl in *; destruct (fin_eq_dec Ridx idx0); subst; eauto.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
  Qed.

  Lemma refine_SatisfiesCrossConstraints'
  : forall qsSchema qs Ridx tup,
    forall idx,
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                Ridx' <> Ridx
                -> forall tup',
                     (GetUnConstrRelation qs Ridx') tup'
                     -> SatisfiesCrossRelationConstraints
                          Ridx' Ridx (indexedElement tup')
                          (EnsembleInsert
                             {| elementIndex := idx;
                                indexedElement := tup |}
                             (GetUnConstrRelation qs Ridx))))
             (@Iterate_Decide_Comp_opt _
                                        (fun Ridx' =>
                                           if (fin_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetUnConstrRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedElement tup') (
                                                                        (EnsembleInsert
                                                                           {| elementIndex := idx;
                                                                              indexedElement := tup |}
                                                                           (GetUnConstrRelation qs Ridx))))
                                               | None => None
                                      end)).
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints.
    apply refine_Iterate_Decide_Comp_equiv; simpl; intros.
    destruct (fin_eq_dec Ridx idx0); subst.
    congruence.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
    intro; eapply H.
    destruct (fin_eq_dec Ridx idx0); subst; eauto.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
  Qed.

  Lemma tupleAgree_refl :
    forall (h : RawHeading)
           (tup : @RawTuple h)
           (attrlist : list (Attributes h)),
      tupleAgree tup tup attrlist.
  Proof.
    unfold tupleAgree; auto.
  Qed.

  Lemma refine_tupleAgree_refl_True :
    forall (h : RawHeading)
           (tup : @RawTuple h)
           (attrlist attrlist' : list (Attributes h)),
      refine {b |
              decides b (tupleAgree tup tup attrlist'
                         -> tupleAgree tup tup attrlist)}
             (ret true).
  Proof.
    unfold refine; intros;  computes_to_inv.
    subst; computes_to_econstructor; simpl; auto using tupleAgree_refl.
  Qed.

  Lemma refine_SatisfiesCrossConstraints_Pre (Q : Prop)
    : forall (qsSchema : RawQueryStructureSchema) qs
             (Ridx :Fin.t _)
             (tup : @RawTuple _),
      refine
        (@Iterate_Decide_Comp_Pre _
                                  (fun Ridx' =>
                                     SatisfiesCrossRelationConstraints
                                       Ridx Ridx' tup
                                       (GetUnConstrRelation qs Ridx')) Q)
        (@Iterate_Decide_Comp_opt_Pre _
                                       (fun Ridx' =>
                                          match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                          | Some CrossConstr =>
                                            Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                          | None => None
                                          end) Q) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp_Pre.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma DeletePrimaryKeysOK {qsSchema}
    : forall (qs : UnConstrQueryStructure qsSchema)
             (Ridx :Fin.t _)
             DeletedTuples
             attrlist1 attrlist2,
      refine {b | (forall tup tup',
                      elementIndex tup <> elementIndex tup'
                      -> GetUnConstrRelation qs Ridx tup
                      -> GetUnConstrRelation qs Ridx tup'
                      -> (FunctionalDependency_P attrlist1 attrlist2 (indexedElement tup) (indexedElement tup')))
                  -> decides b (Mutate.MutationPreservesTupleConstraints
                                  (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples)
                                  (FunctionalDependency_P attrlist1 attrlist2)
             )}
             (ret true).
  Proof.
    unfold Mutate.MutationPreservesTupleConstraints, FunctionalDependency_P;
    intros * v Comp_v;  computes_to_inv; subst.
    computes_to_constructor; simpl.
    intros.
    unfold EnsembleDelete in *; destruct H1; destruct H2; eauto.
  Qed.

  Local Transparent Count.

  Lemma In_UnConstrQuery_In {qsSchema} {A}
    : forall (qs : UnConstrQueryStructure qsSchema) Ridx bod results,
      UnConstrQuery_In qs Ridx bod ↝ results
      -> forall (a : A), List.In a results ->
                         exists (tup' : IndexedRawTuple) results',
                           Ensembles.In _ (GetUnConstrRelation qs Ridx) tup'
                           /\ bod (indexedElement tup') ↝ results'
                           /\ List.In a results'.
  Proof.
    unfold UnConstrQuery_In, QueryResultComp; intros;
    computes_to_inv.
    unfold UnIndexedEnsembleListEquivalence in *; destruct_ex; intuition; subst.
    rewrite map_map in H'.
    remember (GetUnConstrRelation qs Ridx); clear Heqi;
    revert i a results H0 H' H H3;
    induction x; simpl in *; intros;
    computes_to_inv; subst.
    - simpl in H0; intuition.
    - apply in_app_or in H0; intuition.
      exists a; exists v; intuition; try eapply H; eauto.
      inversion H3; subst.
      destruct (IHx (fun tup => tup <> a /\ i tup) _ _ H1 H''); eauto.
      unfold Ensembles.In; intros; intuition; subst; eauto.
      eapply H in H6; intuition.
      apply H4; apply in_map; auto.
      apply H; intuition.
      destruct_ex; intuition.
      eexists x0, x1; intuition.
      apply H2.
  Qed.

  Lemma In_UnConstrQuery_In' {qsSchema} {A}
    : forall (qs : UnConstrQueryStructure qsSchema) Ridx
             (bod : RawTuple -> Comp (list A))
             results
             (a : A) (tup' : IndexedRawTuple),
      Ensembles.In _ (GetUnConstrRelation qs Ridx) tup'
      -> (forall results', bod (indexedElement tup') ↝ results'
                           -> List.In a results')
      -> UnConstrQuery_In qs Ridx bod ↝ results
      -> List.In a results.
  Proof.
    unfold UnConstrQuery_In, QueryResultComp, Ensembles.In; intros.
    computes_to_inv.
    unfold UnIndexedEnsembleListEquivalence in *; destruct_ex; intuition; subst.
    rewrite map_map in H1'.
    remember (GetUnConstrRelation qs Ridx); clear Heqi;
    revert i a results H H0 H1 H1' H4;
    induction x; simpl in *; intros;
    computes_to_inv; subst.
    - simpl in *; intuition; eapply H1; eauto.
    - apply H1 in H; intuition; subst; apply in_or_app; eauto.
      right; inversion H4; subst.
      eapply (IHx (fun tup => tup <> a /\ i tup)); eauto.
      intuition; subst; eauto.
      apply H5; eauto using in_map.
      apply H1; eauto.
      unfold Ensembles.In; intuition; intros; eauto.
      rewrite H1 in H7; intuition.
      subst; eauto using in_map.
      apply H1; eauto.
  Qed.

  Lemma DeleteForeignKeysCheck {qsSchema}
    : forall (qs : UnConstrQueryStructure qsSchema)
             (Ridx Ridx' :Fin.t _)
             (DeletedTuples : Ensemble (RawTuple ))
             (Delete_dec : DecideableEnsemble DeletedTuples)
             (attr : Attributes _)
             (attr' : Attributes _)
             (tupmap : Domain _ attr
                       -> Domain _ attr')
             (AgreeDelete : forall tup tup',
                 tupleAgree tup tup' [attr] ->
                 DeletedTuples tup ->
                 DeletedTuples tup')
             (attr_eq_dec : Query_eq (Domain _ attr))
             (P : Prop)
             (ForeignKey_P_P :
                P -> (forall tup' : IndexedRawTuple,
                         GetUnConstrRelation qs Ridx' tup' ->
                         ForeignKey_P attr' attr tupmap (indexedElement tup')
                                      (GetUnConstrRelation qs Ridx)))
             (tup_map_inj : forall a a', tupmap a = tupmap a' -> a = a'),
      refine {b' |
              P ->
              decides b'
                      (MutationPreservesCrossConstraints
                         (GetUnConstrRelation qs Ridx')
                         (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples)
                         (ForeignKey_P attr' attr tupmap))}
             (x <- Count (For (UnConstrQuery_In
                                 qs Ridx'
                                 (fun tup' =>
                                    UnConstrQuery_In
                                      qs Ridx
                                      (fun tup =>
                                         Where (DeletedTuples tup)
                                               Where (tupmap (GetAttributeRaw tup attr) = GetAttributeRaw tup' attr')
                                               Return ()))));
              ret (match x with
                     0  => true
                   | S _ => false
                   end)).
  Proof.
    simpl; unfold ForeignKey_P; intros.
    intros v Comp_v.
    computes_to_inv; destruct_ex; split_and.
    unfold Count in *;  computes_to_inv.
    destruct v0; simpl in *; subst;  computes_to_inv; subst;
    computes_to_constructor; simpl; unfold not;
    unfold MutationPreservesCrossConstraints; intros.
    - destruct (ForeignKey_P_P H _ H0) as [tup2 [In_tup2 Agree_tup2] ].
      eexists; intuition eauto.
      unfold EnsembleDelete; constructor; unfold In; intros; eauto.
      unfold Complement, Ensembles.In, not; intros.
      unfold Query_For in *;  computes_to_inv.
      rewrite Permutation_nil in Comp_v; symmetry in Comp_v'0; eauto.
      apply (fun x => In_UnConstrQuery_In' _ _ _ _ () _ H0 x Comp_v).
      intros results' H3;
        apply (fun x => In_UnConstrQuery_In' _ _ _ _ () _ In_tup2 x H3).
      intros results'0 H5.
      unfold Query_Where in H5; computes_to_inv;
      simpl in *; intuition.
      computes_to_inv; split_and.
      simpl in H4.
      unfold QSGetNRelSchema, GetNRelSchema in Agree_tup2; simpl in *.
      rewrite Agree_tup2 in H4; pose proof (H4 (refl_equal _)) as H';
      computes_to_inv; simpl in *; subst; simpl; eauto.
      apply Return_inv in H'; subst; simpl; intuition.
      rewrite Comp_v'; destruct v1; try discriminate; reflexivity.
    - unfold Query_For in *;  computes_to_inv.
      eapply In_UnConstrQuery_In with (a := tt) in Comp_v; destruct_ex;
      intuition.
      pose proof (H3 _ H2); pose proof (H0 _ H2); destruct_ex;
      intuition.
      eapply In_UnConstrQuery_In with (a := tt) in H1; destruct_ex;
      intuition.
      unfold EnsembleDelete in *; inversion H5; subst;
      unfold Ensembles.In, Complement, In in *.
      unfold Query_Where in H1; computes_to_inv;  intuition.
      case_eq (@dec _ _ Delete_dec (indexedElement x3)); intros.
      + apply Delete_dec in H1; pose proof (H13 H1) as H'.
        computes_to_inv; split_and.
        unfold indexedTuple in *.
        destruct (A_eq_dec (GetAttributeRaw (indexedElement x3) attr)
                           (GetAttributeRaw (indexedElement x1) attr)).
        * rewrite e in *; setoid_rewrite <- H9 in H15; subst;
          pose proof (H15 (refl_equal _)) as e'; computes_to_inv; simpl in *; subst.
          apply H12; eapply AgreeDelete; eauto.
          unfold tupleAgree; simpl; intros attr'' In_attr''; destruct In_attr'';
          [rewrite H17 in *; eauto | intuition ].
        * rewrite H16 in H11; simpl in *; eauto.
          intros;
            unfold QSGetNRelSchema, GetNRelSchema in *; simpl in *;
            setoid_rewrite <- H17 in H9; eauto.
      + rewrite H14 in H11; simpl in *; eauto.
        intros H'; apply dec_decides_P in H'; congruence.
      + eapply Permutation_in; symmetry in Comp_v'; simpl; eauto.
        destruct v1; simpl in *;
        [ discriminate | destruct u; eauto].
  Qed.

  Lemma InsertForeignKeysCheck {qsSchema}
    : forall
      (qs : UnConstrQueryStructure qsSchema)
      (Ridx Ridx' :Fin.t _)
      (attr : Attributes _)
      (attr' : Attributes _)
      (tupmap : Domain _ attr' -> Domain _ attr)
      tup
      (ForeignKey_P_P :
         (forall tup' : IndexedRawTuple,
             GetUnConstrRelation qs Ridx tup' ->
             ForeignKey_P attr attr' tupmap (indexedElement tup')
                          (GetUnConstrRelation qs Ridx'))),
      Ridx <> Ridx'
      -> refine {b' |
                 decides b'
                         (forall tup',
                             (GetUnConstrRelation qs Ridx) tup' ->
                             ForeignKey_P attr attr' tupmap
                                          (indexedElement tup')
                                          (EnsembleInsert tup (GetUnConstrRelation qs Ridx')))}
                (ret true).
  Proof.
    intros; apply refine_pick_val; simpl; intros.
    unfold ForeignKey_P in *.
    destruct (ForeignKey_P_P _ H0) as [tup'' [In_tup'' ?] ];
      exists tup''; unfold EnsembleInsert; intuition.
  Qed.

End ConstraintCheckRefinements.

Lemma In_flatten_CompList {A} :
  forall (P : Ensemble A)
         (P_dec : forall a, P a \/ ~ P a)
         (il : list (@IndexedElement A))
         (l : list A)
         (a : A),
    List.In a l
    -> flatten_CompList
         (map
            (fun x1 : IndexedElement =>
               Where (P (indexedElement x1))
                     Return (indexedElement x1) ) il) ↝ l
    -> exists a', List.In a' il /\ indexedElement a' = a.
Proof.
  induction il; simpl; intros;  computes_to_inv; subst; simpl in *; intuition.
  apply in_app_or in H; intuition.
  unfold Query_Where in H0; computes_to_inv; intuition.
  destruct (P_dec (indexedElement a)).
  apply H in H0; unfold Query_Return in *; computes_to_inv; subst;
  simpl in H; exists a; simpl in H1; intuition; eauto.
  apply H2 in H0; subst; simpl in *; contradiction.
  destruct (IHil _ _ H1 H0') as [a' [In_a' a'_eq] ]; exists a'; split; eauto.
Qed.

Lemma For_computes_to_In :
  forall {heading} P,
    (forall a, P a \/ ~ P a) ->
    forall seq ens,
      computes_to (For (QueryResultComp (heading := heading) ens
                                        (fun tup => Where (P tup) Return tup))) seq ->
      forall x,
        List.In x seq -> (P x /\ (exists x0, ens x0 /\ indexedRawTuple x0 = x)).
Proof.
  unfold refine, decides;
  unfold Query_For, QueryResultComp; intros * excl;
  induction seq as [ | head seq' IH ]; intros.

  exfalso; intuition.

  computes_to_inv.

  pose proof (permutation_cons_in H') as in_x0.
  apply in_split in in_x0.
  destruct in_x0 as [ x0_before [ x0_after ? ] ]; subst.
  symmetry in H'. apply Permutation_cons_app_inv in H'.

  unfold UnIndexedEnsembleListEquivalence in H; destruct_ex; intuition; subst.

  rewrite map_map in H'0.
  destruct (flatten_CompList_app_cons_inv _ excl _ _ _ _ H'0) as [ x1_before [ x1_middle [ head' [ x1_after (_eq & in_orig & before & middle & after) ] ] ] ]; subst.

  unfold boxed_option in middle; simpl in middle.
  eapply Bind_inv in middle.
  destruct middle as [head'' (middle1 & middle2)].
  apply Pick_inv in middle1.
  apply Bind_inv in middle2.
  destruct middle1 as ( spec1 & spec2 ).
  destruct middle2 as [ nil' (ret_nil & ret_cons) ].
  apply Return_inv in ret_nil; subst.
  rewrite app_nil_r in *; subst.
  apply Return_inv in ret_cons; subst.

  rewrite singleton_neq_nil in spec2.
  destruct (excl (indexedRawTuple head')) as [ H'' | H'' ]; try solve [exfalso; intuition].
  specialize (spec1 H'').

  apply Return_inv in spec1.
  injection spec1; intros; subst.

  destruct H0.

  - subst x; eauto.
  - pose proof (flatten_CompList_app _ _ _ _ before after) as flatten_app.
    eapply IH; try assumption.
    computes_to_econstructor; [ | computes_to_constructor; symmetry; eassumption ].
    computes_to_econstructor.
    pose proof (EnsembleListEquivalence_slice x1_before x1_middle x1_after).
    instantiate (2 := (fun x0 : IndexedRawTuple => ens x0 /\ ~ List.In x0 x1_middle)).
    eapply PickComputes with (a := map indexedElement (x1_before ++ x1_after)).
    econstructor; split; eauto; intuition.
    destruct (H1 ens).
    unfold EnsembleListEquivalence; split; eauto using NoDup_IndexedElement.
    eapply H5; eauto.
    unfold Ensembles.In; split.
    eapply H; apply in_app_or in H2; intuition.
    intros; apply NoDup_IndexedElement in H3; eapply NoDup_app_inv'; eauto using in_app_or.
    repeat rewrite map_app in *; eauto using NoDup_slice.
    unfold boxed_option in *.
    rewrite !map_app, !map_map.
    apply flatten_app.

  - rewrite map_map in H'0.
    destruct (In_flatten_CompList P excl x0 (x0_before ++ head :: x0_after) x) as [x1 [In_x1 x1_eq] ];
      eauto.
    eapply Permutation_in with (l := head :: (x0_before ++ x0_after)).
    eapply Permutation_middle.
    simpl in *; intuition; right; eauto using Permutation_in.
    exists x1; split; eauto.
    apply H; eauto.
Qed.

Lemma UnIndexedEnsembleListEquivalence_eqv {A}
  : forall ens l,
    @UnIndexedEnsembleListEquivalence A ens l ->
    exists l',
      EnsembleListEquivalence ens l' /\ l = map indexedElement l'.
Proof.
  unfold UnIndexedEnsembleListEquivalence, EnsembleListEquivalence; intros.
  destruct_ex; intuition.
  exists x; intuition; eauto using NoDup_IndexedElement.
Qed.

Lemma For_computes_to_nil :
  forall {heading} P,
  forall ens,
    computes_to (For (QueryResultComp (heading := heading) ens
                                      (fun tup => Where (P tup) Return tup))) [] ->
    forall x,
      ens x -> ~ (P (indexedRawTuple x)).
Proof.
  unfold refine, decides, Count, Query_For, QueryResultComp; intros **.
  computes_to_inv.
  symmetry in H'; apply Permutation_nil in H'; subst.
  apply UnIndexedEnsembleListEquivalence_eqv in H; destruct_ex; intuition; subst.

  apply H2 in H0.
  apply in_split in H0.
  destruct H0 as [ x1_before [ x1_after _eq ] ]; subst.
  rewrite map_map in H'0.
  eapply (@FlattenCompList.flatten_CompList_nil _ P); unfold boxed_option; eauto; intuition.
Qed.

Lemma decidable_excl :
  forall {A : Type} (P : Ensemble A) (P_dec : DecideableEnsemble P),
    (forall (a: A), P a \/ ~ P a).
Proof.
  intros ??? a.
  destruct (dec a) eqn:eqdec;
    [ rewrite dec_decides_P in eqdec | rewrite Decides_false in eqdec ]; intuition.
Qed.

Lemma refine_constraint_check_into_QueryResultComp :
  forall heading R P' P
         (P_dec : DecideableEnsemble P),
    Same_set _ (fun tup => P (indexedElement tup)) P'
    -> refine
         (Pick (fun (b : bool) =>
                  decides b
                          (exists tup2: @IndexedRawTuple heading,
                              (R tup2 /\ P' tup2))))
         (Bind
            (Count (For (QueryResultComp R (fun tup => Where (P tup) Return tup))))
            (fun count => ret (negb (beq_nat count 0)))).
Proof.
  Local Transparent Count.
  unfold refine, Count, UnConstrQuery_In;
    intros * excl * P_iff_P' pick_comp ** .
  computes_to_inv; subst.

  computes_to_constructor.

  destruct (Datatypes.length v0) eqn:eq_length;
    destruct v0 as [ | head tail ]; simpl in *; try discriminate; simpl.

  pose proof (For_computes_to_nil _ R H).
  rewrite not_exists_forall; intro a; rewrite not_and_implication; intros.
  unfold not; intros; eapply H0; eauto; apply P_iff_P'; eauto.

  apply For_computes_to_In with (x := head) in H; try solve [intuition].
  destruct H as ( p & [ x0 ( in_ens & _eq ) ] ); subst.
  eexists; split; eauto; apply P_iff_P'; eauto.

  apply decidable_excl; assumption.
Qed.

Lemma refine_constraint_check_into_query' :
  forall {schm tbl} (c : UnConstrQueryStructure schm) P' P
         (P_dec : DecideableEnsemble P),
    Same_set _ (fun tup => P (indexedElement tup)) P'
    -> refine
         (Pick (fun (b : bool) =>
                  decides b
                          (exists tup2: @IndexedRawTuple _,
                              (GetUnConstrRelation c tbl tup2 /\ P' tup2))))
         (Bind
            (Count (For (UnConstrQuery_In c tbl (fun tup => Where (P tup) Return tup))))
            (fun count => ret (negb (beq_nat count 0)))).
Proof.
  intros; rewrite refine_constraint_check_into_QueryResultComp; eauto.
  reflexivity.
Qed.

Corollary refine_constraint_check_into_query :
  forall {schm tbl} P (c : UnConstrQueryStructure schm)
         (P_dec : DecideableEnsemble P),
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (exists tup2: @IndexedRawTuple _,
                           (GetUnConstrRelation c tbl tup2 /\ P (indexedRawTuple tup2)))))
      (Bind
         (Count (For (UnConstrQuery_In c tbl (fun tup => Where (P tup) Return tup))))
         (fun count => ret (negb (beq_nat count 0)))).
Proof.
  intros.
  setoid_rewrite refine_constraint_check_into_query'; eauto.
  reflexivity.
  unfold Same_set, Included; intuition.
Qed.

Lemma refine_constraint_check_into_query'' :
  forall heading R P' P
         (P_dec : DecideableEnsemble P),
    Same_set _ (fun tup => P (indexedElement tup)) P'
    -> refine
         (Pick (fun (b : bool) =>
                  decides b
                          (exists tup2: @IndexedRawTuple heading,
                              (R tup2 /\ P' tup2))))
         (Bind
            (Count (For (QueryResultComp R (fun tup => Where (P tup) Return tup))))
            (fun count => ret (negb (beq_nat count 0)))).
Proof.
  Local Transparent Count.
  unfold refine, Count, UnConstrQuery_In;
    intros * excl * P_iff_P' pick_comp ** .
  computes_to_inv; subst.

  computes_to_constructor.

  destruct (Datatypes.length v0) eqn:eq_length;
    destruct v0 as [ | head tail ]; simpl in *; try discriminate; simpl.

  pose proof (For_computes_to_nil _ R H).
  rewrite not_exists_forall; intro a; rewrite not_and_implication; intros.
  unfold not; intros; eapply H0; eauto; apply P_iff_P'; eauto.

  apply For_computes_to_In with (x := head) in H; try solve [intuition].
  destruct H as ( p & [ x0 ( in_ens & _eq ) ] ); subst.
  eexists; split; eauto; apply P_iff_P'; eauto.

  apply decidable_excl; assumption.
Qed.

Definition refine_foreign_key_check_into_query {schm tbl} :=
  @refine_constraint_check_into_query schm tbl.

Lemma refine_functional_dependency_check_into_query :
  forall {schm : RawQueryStructureSchema}
         {tbl}
         (ref : @RawTuple (@GetNRelSchemaHeading _ (qschemaSchemas schm) tbl))
         args1
         args2
         (c : UnConstrQueryStructure schm),
    DecideableEnsemble (fun x : RawTuple => tupleAgree_computational ref x args1 /\
                                            ~ tupleAgree_computational ref x args2) ->
    ((forall tup' : IndexedRawTuple,
         GetUnConstrRelation c tbl tup'
         -> FunctionalDependency_P args2 args1 ref (indexedElement tup'))
     <-> (forall tup',
             ~ (GetUnConstrRelation c tbl tup'
                /\ tupleAgree ref (indexedElement tup') args1
                /\ ~ tupleAgree ref (indexedElement tup') args2))) ->
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (forall tup',
                           GetUnConstrRelation c tbl tup' ->
                           FunctionalDependency_P args2 args1 ref (indexedElement tup'))))
      (Bind (Count
               For (UnConstrQuery_In c tbl
                                     (fun tup =>
                                        Where (tupleAgree_computational ref tup args1 /\
                                               ~ tupleAgree_computational ref tup args2)
                                              Return tup)))
            (fun count => ret (beq_nat count 0))).
Proof.
  intros * is_dec ** .

  setoid_replace (forall tup', GetUnConstrRelation c tbl tup' ->
                               tupleAgree ref (indexedElement tup') args1
                               -> tupleAgree ref (indexedElement tup') args2)
  with           (forall tup', ~ (GetUnConstrRelation c tbl tup' /\
                                  tupleAgree ref (indexedElement tup') args1 /\
                                  ~ tupleAgree ref (indexedElement tup') args2)); eauto.

  setoid_rewrite refine_decide_negation.
  setoid_rewrite (tupleAgree_equivalence ref).

  setoid_rewrite (@refine_constraint_check_into_query _ _
                                                      (fun x => tupleAgree_computational ref x args1 /\
                                                                          ~ tupleAgree_computational ref x args2)); try assumption.

  Opaque Query_For Count.
  simplify with monad laws.
  setoid_rewrite negb_involutive.
  reflexivity.
Qed.

Lemma refine_functional_dependency_check_into_query' :
  forall {schm : RawQueryStructureSchema}
         {tbl}
         ref
         args1
         args2
         (c : UnConstrQueryStructure schm),
    DecideableEnsemble (fun x => tupleAgree_computational x ref args1 /\
                                         ~ tupleAgree_computational x ref args2) ->
    ((forall tup' ,
         GetUnConstrRelation c tbl tup'
         -> FunctionalDependency_P args2 args1 (indexedElement tup') ref)
     <-> (forall tup',
             ~ (GetUnConstrRelation c tbl tup'
                /\ tupleAgree (indexedElement tup') ref args1
                /\ ~ tupleAgree (indexedElement tup') ref args2))) ->
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (forall tup',
                           GetUnConstrRelation c tbl tup' ->
                           FunctionalDependency_P args2 args1 (indexedElement tup') ref)))
      (Bind (Count
               For (UnConstrQuery_In c tbl
                                     (fun tup =>
                                        Where (tupleAgree_computational tup ref args1 /\
                                               ~ tupleAgree_computational tup ref args2)
                                              Return tup)))
            (fun count => ret (beq_nat count 0))).
Proof.
  intros * is_dec ** .

  setoid_replace (forall tup', GetUnConstrRelation c tbl tup' ->
                               tupleAgree (indexedElement tup') ref args1
                               -> tupleAgree (indexedElement tup') ref args2)
  with           (forall tup', ~ (GetUnConstrRelation c tbl tup' /\
                                  tupleAgree (indexedElement tup') ref args1 /\
                                  ~ tupleAgree (indexedElement tup') ref args2)); eauto.

  setoid_rewrite refine_decide_negation.
  setoid_rewrite tupleAgree_equivalence.
  setoid_rewrite (@refine_constraint_check_into_query _ _
                                                      (fun x => tupleAgree_computational x ref args1 /\
                                                                          ~ tupleAgree_computational x ref args2)); try assumption.

  Opaque Query_For Count.
  simplify with monad laws.
  setoid_rewrite negb_involutive.
  reflexivity.
Qed.

 Theorem FunctionalDependency_symmetry
  : forall A H (f : _ -> _ -> Comp A) (P : _ -> Prop) attrlist1 attrlist2 n,
    refine (x1 <- {b | decides b
                               (forall tup' : @IndexedRawTuple H,
                                   P tup'
                                   -> FunctionalDependency_P attrlist1 attrlist2 n (indexedElement tup'))};
            x2 <- {b | decides b (forall tup' : @IndexedRawTuple H,
                                     P tup'
                                     -> FunctionalDependency_P attrlist1 attrlist2 (indexedElement tup') n)};
            f x1 x2)
           (x1 <- {b | decides b (forall tup' : @IndexedRawTuple H,
                                     P tup'
                                     -> FunctionalDependency_P attrlist1 attrlist2 n (indexedElement tup'))};
            f x1 x1).
Proof.
  unfold refine, FunctionalDependency_P; intros.
  computes_to_inv; firstorder.
  computes_to_inv; firstorder.
  repeat (computes_to_econstructor; eauto).
  destruct v0; simpl in *; unfold tupleAgree in *; intros; eauto.
  erewrite H0; eauto; intros; rewrite H2; eauto.
  unfold not; intros; eapply H0; intros.
  rewrite H1; eauto; intros; rewrite H3; eauto.
Qed.

Theorem FunctionalDependency_symmetry'
  : forall H P attrlist1 attrlist2 n b',
    decides b'
            (forall tup' : @IndexedRawTuple H,
                P tup'
                -> FunctionalDependency_P attrlist1 attrlist2 n (indexedElement tup'))
    -> refine {b | decides b (forall tup' : @IndexedRawTuple H,
                                 P tup'
                                 -> FunctionalDependency_P attrlist1 attrlist2 (indexedElement tup') n)}
                  (ret b').
Proof.
  unfold FunctionalDependency_P; intros.
  refine pick val b'.
  reflexivity.
  destruct b'; simpl in *; unfold tupleAgree in *; intros; eauto.
  erewrite H0; eauto; intros; rewrite H1; eauto.
  unfold not; intros; eapply H0; intros.
  rewrite H1; eauto; intros; rewrite H2; eauto.
Qed.

Lemma if_duplicate_cond_eq {A}
  : forall (i : bool) (t e : A),
    (if i then (if i then t else e) else e) = if i then t else e.
Proof.
  destruct i; reflexivity.
Qed.

Global Instance nil_List_Query_eq :
  List_Query_eq [] :=
  { As_Query_eq := tt  }.

Global Instance cons_List_Query_eq
       {A : Type}
       {As : list Type}
       {A_Query_eq : Query_eq A}
       {As_Query_eq' : List_Query_eq As}
  :
    List_Query_eq (A :: As) :=
  { As_Query_eq := (A_Query_eq, As_Query_eq) }.

Theorem UniqueAttribute_symmetry
  : forall A (f : _ -> _ -> Comp A) H (P : _ -> Prop) attr n,
    refine (b1 <- {b | decides b
                               (forall tup' : @IndexedRawTuple H,
                                   P tup'
                                   -> UniqueAttribute' attr n (indexedElement tup'))};
           b2 <- {b | decides b (forall tup' : @IndexedRawTuple H,
                                     P tup'
                                     -> UniqueAttribute' attr (indexedElement tup') n)}; f b1 b2)
           (b1 <- {b | decides b
                               (forall tup' : @IndexedRawTuple H,
                                   P tup'
                                   -> UniqueAttribute' attr n (indexedElement tup'))}; f b1 b1).
Proof.
  unfold refine, UniqueAttribute'; intros.
  computes_to_inv; firstorder.
  repeat (computes_to_econstructor; eauto).
  destruct v0; simpl in *; unfold not in *; intros; eauto.
Qed.

Lemma refine_uniqueness_check_into_query' :
  forall {schm : RawQueryStructureSchema}
         idx
         tup
         attr
         (c : UnConstrQueryStructure schm),
    Query_eq (Domain (GetNRelSchemaHeading (qschemaSchemas schm) idx) attr)
    -> refine
      {b | decides b
                   (forall tup' : @IndexedRawTuple _,
                       GetUnConstrRelation c idx tup'
                       -> UniqueAttribute' attr tup (indexedElement tup'))}
      (c <- (Count
               For (UnConstrQuery_In c idx
                                     (fun tup' =>
                                        Where (GetAttributeRaw tup attr
                                               = GetAttributeRaw tup' attr)
                                              Return tup')));
            (ret (beq_nat c 0))).
Proof.
  intros.
  setoid_replace (forall tup', GetUnConstrRelation c idx tup' ->
                               UniqueAttribute' attr tup (indexedElement tup'))
with           (forall tup', ~ (GetUnConstrRelation c idx tup' /\
                                GetAttributeRaw tup attr = GetAttributeRaw  (indexedElement tup') attr)) by
      (unfold UniqueAttribute'; intuition eauto).
  setoid_rewrite refine_decide_negation.
  rewrite (@refine_constraint_check_into_query _ _
                                                      (fun tup' => GetAttributeRaw tup attr = GetAttributeRaw tup' attr)) by eauto with typeclass_instances.
  simplify with monad laws.
  setoid_rewrite negb_involutive.
  reflexivity.
Qed.


Require Import Kami.AllNotations.
Require Import StdLibKami.RegArray.Ifc.

Section Spec.
  Context {ifcParams : Ifc.Params}.
  Local Notation Idx := (Bit (Nat.log2_up size)).
  Local Definition arrayName := (name ++ ".list")%string.

  Local Open Scope kami_expr.
  Local Open Scope kami_action.

  Local Definition read ty (idx: ty Idx) : ActionT ty k :=
    Read array: (Array size k) <- arrayName;
    Ret (#array @[ #idx]).

  Local Definition write ty (writeRq : ty (WriteRq (Nat.log2_up size) k)): ActionT ty Void :=
    Read array: (Array size k) <- arrayName;
    Write arrayName: (Array size k) <- #array @[ #writeRq @% "addr" <- #writeRq @% "data" ];
    Retv.

  Local Definition regs : list RegInitT := makeModule_regs (Register arrayName : (Array size k) <- Default)%kami.

  Definition spec : Ifc :=
    {|
      Ifc.regs := regs;
      Ifc.regFiles := nil;
      Ifc.read := read;
      Ifc.write := write
    |}.

End Spec.


Require Export concurrency.paco.src.paconotation concurrency.paco.src.pacotac concurrency.paco.src.pacodef.
Set Implicit Arguments.

(** ** Type Class for acc, mult, fold and unfold
*)

Class paco_class (A : Prop) :=
{ pacoacctyp: Type
; pacoacc : pacoacctyp
; pacomulttyp: Type
; pacomult : pacomulttyp
; pacofoldtyp: Type
; pacofold : pacofoldtyp
; pacounfoldtyp: Type
; pacounfold : pacounfoldtyp
}.

Definition get_paco_cls {A} {cls: paco_class A} (a: A) := cls.

Create HintDb paco.

Ltac paco_class TGT method :=
  let typ := fresh "_typ_" in let lem := fresh "_lem_" in
  let TMP := fresh "_tmp_" in let X := fresh "_X_" in
  let CLS := fresh "_CLS_" in
  evar (typ: Type); evar (lem: typ);
  assert(TMP: TGT -> True) by (
    intros X; set (CLS := method _ (get_paco_cls X));
    repeat red in CLS; clear X; revert lem;
    match goal with [CLS := ?v |-_] => instantiate (1:= v) end;
    clear CLS; exact I);
  clear TMP; unfold typ in *; clear typ; revert lem.

(** ** pfold tactic
  - [pfold]
*)

Ltac pfold := let x := fresh "_x_" in
  repeat red;
  match goal with [|- ?G] => paco_class G (@pacofold) end;
  intro x; match goal with [x:=?lem|-_] => clear x; eapply lem end.

(** ** punfold tactic
  - [punfold H]
*)

Ltac punfold H := let x := fresh "_x_" in
  repeat red in H;
  let G := type of H in paco_class G (@pacounfold);
  intro x; match goal with [x:=?lem|-_] => clear x; eapply lem in H end;
  eauto with paco.

(** ** pmult tactic
  - [pmult]
*)

Ltac pmult := let x := fresh "_x_" in
  repeat red;
  match goal with [|- ?G] => paco_class G (@pacomult) end;
  intro x; match goal with [x:=?lem|-_] => clear x; eapply lem end.

(** ** pcofix tactic
  - [pcofix CIH [with r]]
*)

Tactic Notation "pcofix" ident(CIH) "with" ident(r) :=
  let x := fresh "_x_" in
  generalize _paco_mark_cons; repeat intro; repeat red;
  match goal with [|- ?G] =>
  paco_class G (@pacoacc); intro x;
  match goal with [x:=?lem|-_] => clear x;
    paco_revert_hyp _paco_mark;
    pcofix CIH using lem with r
  end end.

Tactic Notation "pcofix" ident(CIH) := pcofix CIH with r.

(** ** [pclearbot] simplifies all hypotheses of the form [upaco{n} gf bot{n}] to [paco{n} gf bot{n}].
*)

Ltac pclearbot :=
  let X := fresh "_X" in
  repeat match goal with
  | [H: appcontext[pacoid] |- _] => red in H; destruct H as [H|X]; [|contradiction X]
  end.

(** ** [pdestruct H] and [pinversion H]
*)

Ltac pdestruct H := punfold H; destruct H; pclearbot.

Ltac pinversion H := punfold H; inversion H; pclearbot.

(** ** pmonauto tactic
  - [pmonauto]
*)

Ltac pmonauto :=
  let IN := fresh "IN" in try (repeat intro; destruct IN; eauto; fail).

(** Tactics for Internal Use Only *)

Ltac paco_cofix_auto :=
  cofix; repeat intro;
  match goal with [H: _ |- _] => destruct H end; econstructor;
  try (match goal with [H: _|-_] => apply H end); intros;
  lazymatch goal with [PR: _ |- _] => match goal with [H: _ |- _] => apply H in PR end end;
  repeat match goal with [ H : _ \/ _ |- _] => destruct H end; first [eauto; fail|eauto 10].

Ltac paco_revert :=
  match goal with [H: _ |- _] => revert H end.

Notation "p <_paco_0= q" :=
  (forall (PR: p : Prop), q : Prop)
  (at level 50, no associativity).

Notation "p <_paco_1= q" :=
  (forall _paco_x0 (PR: p _paco_x0 : Prop), q _paco_x0 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_2= q" :=
  (forall _paco_x0 _paco_x1 (PR: p _paco_x0 _paco_x1 : Prop), q _paco_x0 _paco_x1 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_3= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 (PR: p _paco_x0 _paco_x1 _paco_x2 : Prop), q _paco_x0 _paco_x1 _paco_x2 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_4= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_5= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_6= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_7= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_8= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_9= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_10= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_11= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_12= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_13= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_14= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 _paco_x13 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 _paco_x13 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 _paco_x13 : Prop)
  (at level 50, no associativity).

Notation "p <_paco_15= q" :=
  (forall _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 _paco_x13 _paco_x14 (PR: p _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 _paco_x13 _paco_x14 : Prop), q _paco_x0 _paco_x1 _paco_x2 _paco_x3 _paco_x4 _paco_x5 _paco_x6 _paco_x7 _paco_x8 _paco_x9 _paco_x10 _paco_x11 _paco_x12 _paco_x13 _paco_x14 : Prop)
  (at level 50, no associativity).


(** * Intuitionistic sequent calculus LJT *)

Set Implicit Arguments.

(* Require Import decidable_IN. *)
Require Import associations.
Require Import associations_extra.
Require Import language_syntax.
Require Import variable_sets.
Require Import substitution_wellformedness.
Require Import sublist.
Require Import fresh_name.
Require Import renaming.

(** For the presentation of predicate logic, we adopt sequent calculus
   to represent proofs. The advantage of such an approach is that
   it has an easy-to-define notion of normal form (it is merely
   the absence of the cut rule). A disadvantage is that it is less
   natural than the so-called natural deduction.

   The Gentzen-style sequent calculus [LJT] is obtained from the
   intuitionistic sequent calculus [LJ] by restricting the use of
   the left introduction rules of the implication and the universal
   quantification.

   Herbelin and Mints showed that there is a one-to-one correspondence
   between cut-free proofs in [LJT] and normal lambda-terms.
   This implies that LJT is a Curry-Howard-de Bruijn-style proof system. *)

Reserved Notation "Ga |- A" (at level 70).
Reserved Notation "Ga ;; A |- C" (at level 70, A at next level).

(** ** Prove and Well-Formedness *)

Inductive prove : context -> fml -> Type :=
  | ProofCont : forall (A C: fml) (Ga : context),
    IN_ctx A Ga -> Ga ;; A |- C -> Ga |- C

  | ProofImplyR : forall B C Ga,
    B :: Ga |- C -> Ga |- B --> C

  | ProofForallR : forall y (B : fml) Ga (a : name),
    a # op_c (B :: Ga) ->
    Ga |- open B y (Par a) ->
    Ga |- (Forall y B)

  where "Ga |- A" := (prove Ga A)

with prove_stoup : context -> fml -> fml -> Type :=
  | ProofAxiom Ga C: wf_c Ga -> wf C -> Ga ;; C |- C

  | ProofImplyL Ga D : forall B C,
    Ga |- B -> Ga ;; C |- D -> Ga ;; (B --> C) |- D

  | ProofForallL Ga C : forall y (u : trm) (B : fml),
    wf_t u ->
    Ga ;; open B y u |- C ->
    Ga ;; Forall y B |- C

  where " Ga ;; B |- A " := (prove_stoup Ga B A).

Notation "Ga |- A" := (prove Ga A) (at level 70).
Notation "Ga ;; A |- C" := (prove_stoup Ga A C) (at level 70, A at next level).

(** REMARKS:

   - All the formulae occurring in derivations are well-formed.
     This is possible because we can primarily focus on [formula = pformula nil].

   - The so-called [Exists-Fresh] style of quantification is used for the right
     universal quantification. *)

Lemma wf_prove :
  forall Ga A,
    Ga |- A -> wf_c Ga /\ wf A

    with wf_prove_stoup :
  forall Ga A B,
    Ga ;; A |- B -> wf_c Ga /\ (wf A /\ wf B).
Proof.
  (* wf_prove *)
  - induction 1.
    + cut (wf_c Ga /\ wf A /\ wf C); auto; tauto.
    + destruct IHprove as [H0 H1].
      inversion H0; split; auto; auto using wImply.
    + destruct IHprove; split; eauto using wForall.

  (* wf_prove_stoup *)
  - induction 1; auto.
    + destruct IHprove_stoup as [H1 H2]; destruct H2 as [H2 H3];
      repeat split; try apply wImply; auto.
      destruct (wf_prove Ga B p); auto.

    + repeat (split; try tauto); apply open_forall_wf with (u := u);
      tauto.
Defined.

Hint Resolve wf_prove wf_prove_stoup.
Hint Rewrite wf_prove wf_prove_stoup.

(** ** Weakening *)

(** Simple structural induction on derication does not work.

   - This is a well-known issue about the [Exists-Fresh] style of quantification.

   - The [Exists-Fresh] style of quantification provides too _weak_ an induction principle.

   - We suggest a solution to that issue using simultaneous [renaming].

   - No alpha-conversion is necessary. *)

(** Generalized Weakening Lemma  *)

Lemma weakening_gen : forall Ga De A eta,
  sub_ctx_pre Ga De ->
  wf_c De ->
  Ga |- A ->
  rename_c eta De |- rename eta A

with weakening_stoup_gen : forall Ga De A C eta,
  sub_ctx_pre Ga De ->
  wf_c De ->
  Ga ;; A |- C ->
  rename_c eta De ;; rename eta A |- rename eta C.
Proof.
  - destruct 3; simpl.
    + apply ProofCont with (rename eta A).
      * apply rename_IN_ctx; auto with datatypes.
      * apply weakening_stoup_gen with Ga; assumption.
    + apply ProofImplyR.
      change (rename_c eta (B :: De) |- rename eta C);
      apply weakening_gen with (B :: Ga); auto.
      * auto using sub_cons_3.
      * apply wf_prove in H1; destruct H1 as [HL HR]. apply wCons; auto.
        apply wf_c_wf with (B :: Ga); auto with datatypes.
    + set (a0 := new
                   ((a::nil) ++ op_c De ++ op B ++
                             op_c (rename_c eta De) ++
                             op (Forall y (rename eta B)) ++
                             dom eta ++ image eta ++
                             op (Forall y B) ++ op_c Ga)).

      simpl in n; destruct_notin.
      assert (a0 <> a).
      * contradict H4; subst; apply IN_eq.
      * { rewrite <- context_rename_fresh with (a:=a)(a0:=a0); auto.
          set (De0 := rename_c ((a,a0) :: nil) De).
          rewrite <- rename_fresh with (a:=a0)(a0:= eta ** a); auto.
          apply ProofForallR with a0.
          - simpl ; apply notIN_app_2; try assumption;
            [ apply notIN_op_rename | apply notIN_op_rename_c]
            ; congruence.
          - rewrite <- rename_c_fresh with (a:=a) (a0:=a0); auto.
            + rewrite <- rename_fresh with (a:=a) (a0:=a0); auto.
              set (eta0:= (a, a0) :: (a0, eta ** a) :: eta). unfold open.
              assert (HH :  ((y, (Par a0)):: nil)= (rename_a eta0 ((y, Par a) :: nil))).
            subst eta0; simpl; case_var; subst; auto; intuition.
            {rewrite HH. rewrite <- rename_subst.
             - apply weakening_gen with Ga; auto.
               + apply sub_ctx_fresh_cst; assumption.
               + apply (rename_wf_c ((a, a0) :: nil) H0).
             - apply wf_fml_sub_name. apply open_forall_wf with (u:= Par a).
               destruct (@wf_prove Ga (open B y (Par a)) H1); auto.
            }
            + subst De0; change a0 with (nil ** a0);
              apply notIN_op_rename_c; auto; tauto.
        }

  (* stoup part  *)
  - destruct 3.
    + apply ProofAxiom.
      * apply rename_wf_c; assumption.
      * apply rename_wf_f; assumption.

    + apply ProofImplyL; eauto.
    + simpl; apply ProofForallL with (u:=(rename_t eta u)).
      * auto using rename_wf_t.
      * { unfold open;
          replace ((y, (rename_t eta u)) :: nil)
                      with (rename_a eta ((y,  u) :: nil)).
          - rewrite <- rename_subst; eauto. change (dom ((y, u) :: nil)) with (y:: nil).
            apply wf_fml_sub_name; apply open_forall_wf with u.
            destruct (@wf_prove_stoup Ga (open B y u) C H1); tauto.
          - tauto.
        }
Defined.

Lemma weakening : forall Ga De A,
  sub_ctx_pre Ga De ->
  wf_c De ->
  Ga |- A ->
  De |- A.
Proof.
  intros.
  rewrite <- (rename_c_nil De); rewrite <- (rename_nil A).
  apply weakening_gen with Ga; auto.
Defined.

Lemma weakening_stoup : forall Ga De A C,
    sub_ctx_pre Ga De ->
    wf_c De ->
    Ga ;; A |- C ->
    De ;; A |- C.
Proof.
  intros.
  rewrite <- (rename_c_nil De).
  rewrite <- (rename_nil A);
  rewrite <- (rename_nil C).
  eauto using weakening_stoup_gen.
Defined.

(** Renaming Lemma *)

Lemma renaming_lamma : forall Ga A eta,
  Ga |- A ->
  rename_c eta Ga |- rename eta A.
Proof.
  intros. apply weakening_gen with Ga; auto.
  apply (@wf_prove Ga A); assumption.
Defined.

Lemma renaming_stoup : forall Ga A C eta,
  Ga ;; A |- C ->
  rename_c eta Ga ;; rename eta A |- rename eta C.
Proof.
  intros; apply weakening_stoup_gen with Ga;
  auto; unfold sublist; apply (@wf_prove_stoup Ga A C H); auto.
Defined.


(** This file contains generic functions for manipulating,
 ** (i.e. substituting and finding) unification variables
 **)
Require Import Coq.omega.Omega.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.ListNth.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Nat.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Lambda.ExprLift.
Require Import MirrorCore.Lambda.ExprDFacts.
Require Import MirrorCore.Lambda.ExprD.

Set Implicit Arguments.
Set Strict Implicit.

Require Import Coq.Logic.FunctionalExtensionality.

Section substitute.
  Variable typ : Set.
  Variable func : Set.

  Section subst'.
    Variable lookupU : uvar -> forall t, (expr typ func -> t) -> t -> t.
    Variable lookupV : var -> forall t, (expr typ func -> t) -> t -> t.

    Fixpoint subst' (lift_by : nat) (e : expr typ func)
    : expr typ func :=
      match e with
        | Var v => match lt_rem v lift_by with
                     | None => Var v
                     | Some diff =>
                       lookupV diff (lift 0 lift_by) e
                   end
        | Inj _ => e
        | UVar u => lookupU u (lift 0 lift_by) e
        | App l r => App (subst' lift_by l) (subst' lift_by r)
        | Abs t e => Abs t (subst' (S lift_by) e)
      end.
  End subst'.

  Definition subst
             (lookupU : uvar -> forall t, (expr typ func -> t) -> t -> t)
             (lookupV : var -> forall t, (expr typ func -> t) -> t -> t)
             (under : nat) (e : expr typ func)
  : expr typ func :=
    subst' lookupU lookupV under e.

  Variable RType_typ : RType typ.
  Variable Typ2_Fun : Typ2 _ RFun.
  Context {RSym_func : RSym func}.

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

(*
  Theorem lift_0 : forall (e : expr typ func) u, Lift.lift u 0 e = e.
  Proof.
    induction e; simpl; intros; Cases.rewrite_all_goal; auto.
    consider (v ?[ lt ] u); auto.
  Qed.
*)

  Definition Natural {T} (f : forall t, (T -> t) -> t -> t) : Prop :=
       (exists v, forall t ret none, f t ret none = ret v)
    \/ (forall t ret none, f t ret none = none).

  Lemma typeof_expr_subst'
  : forall (lookupU lookupV : nat -> forall t, (expr _ _ -> t) -> t -> t) tus tus' tvs tvs'
      (HNU : forall n, Natural (lookupU n))
      (HNV : forall n, Natural (lookupV n))
      (HlookupV : forall v e t,
         nth_error tvs v = Some t ->
         typeof_expr tus tvs e = Some t ->
         typeof_expr tus' tvs' (lookupV v _ (fun x => x) e) = Some t)
      (HlookupU : forall u e t,
         nth_error tus u = Some t ->
         typeof_expr tus tvs e = Some t ->
         typeof_expr tus' tvs' (lookupU u _ (fun x => x) e) = Some t)
      e y tvex,
      typeof_expr tus (tvex ++ tvs) e = Some y ->
      typeof_expr tus' (tvex ++ tvs')
                     (subst' lookupU lookupV (length tvex) e) = Some y.
  Proof.
    induction e; simpl; intros; eauto.
    { generalize (lt_rem_sound (length tvex) v).
      destruct (lt_rem v (length tvex)); intros.
      { destruct H0; subst.
        specialize (HlookupV (v - length tvex)).
        destruct (HNV (v - length tvex)).
        { destruct H1.
          revert HlookupV.
          setoid_rewrite H1.
          intros.
          etransitivity; [ eapply (@typeof_expr_lift _ _ _ _ _ tus' x nil tvex tvs') | ].
          simpl.
          rewrite nth_error_app_R in H; eauto.
          eapply H2; eauto.
          instantiate (1 := Var (v - length tvex)).
          eauto. }
        { generalize (HlookupV (Var (v - length tvex)) y). setoid_rewrite H1.
          simpl. intros.
          rewrite nth_error_app_R in H; eauto.
          rewrite nth_error_app_R; eauto. } }
      { rewrite nth_error_app_L in H; auto.
        simpl. rewrite nth_error_app_L; auto. } }
    { forwardy.
      erewrite IHe1; eauto.
      erewrite IHe2; eauto. }
    { forwardy.
      inv_all; subst.
      specialize (IHe y0 (t :: tvex)); simpl in IHe.
      rewrite IHe; auto. }
    { generalize (HlookupU u).
      destruct (HNU u) as [ [ ? ? ] | ? ]; setoid_rewrite H0.
      { etransitivity.
        eapply (@typeof_expr_lift _ _ _ _ _ tus' _ nil tvex tvs').
        simpl. eapply H1; eauto.
        instantiate (1 := UVar u). assumption. }
      { simpl. intros.
        specialize (H1 (UVar u) y). auto. } }
  Qed.

  Theorem lambda_exprD_subst'
  : forall lookupU lookupV tus tvs tus' tvs' P
      (HNU : forall u, Natural (lookupU u)) (HNV : forall v, Natural (lookupV v))
      (HlookupV : forall t e v vD vD_orig,
         nth_error_get_hlist_nth _ tvs v = Some (@existT _ _ t vD) ->
         lambda_exprD tus tvs t e = Some vD_orig ->
         exists vD',
           lambda_exprD tus' tvs' t (lookupV v _ (fun x => x) e) = Some vD' /\
           forall us vs us' vs',
             P us vs us' vs' ->
             vD_orig us vs = vD vs ->
             vD vs = vD' us' vs')
      (HlookupU : forall t e v vD vD_orig,
         nth_error_get_hlist_nth _ tus v = Some (@existT _ _ t vD) ->
         lambda_exprD tus tvs t e = Some vD_orig ->
         exists vD',
           lambda_exprD tus' tvs' t (lookupU v _ (fun x => x) e) = Some vD' /\
           forall us vs us' vs',
             P us vs us' vs' ->
             vD_orig us vs = vD us ->
             vD us = vD' us' vs'),
      forall e tvex (t : typ) eD,
        lambda_exprD tus (tvex ++ tvs) t e = Some eD ->
        exists eD',
          lambda_exprD tus' (tvex ++ tvs') t (subst' lookupU lookupV (length tvex) e) = Some eD' /\
          forall us vs us' vs' vex,
            P us vs us' vs' ->
            eD us (hlist_app vex vs) = eD' us' (hlist_app vex vs').
  Proof.
    induction e; simpl; intros.
    { generalize (lt_rem_sound (length tvex) v).
      destruct (lt_rem v (length tvex)).
      { destruct 1.
        destruct (HNV n) as [ [ ? ? ] | ? ].
        { generalize (HlookupV t (Var n) n); clear HlookupU HlookupV.
          autorewrite with exprD_rw in *; simpl in *.
          subst.
          forwardy.
          eapply nth_error_get_hlist_nth_appR in H0; eauto.
          simpl in *. forward_reason; inv_all; subst.
          Cases.rewrite_all_goal.
          destruct y.
          intro XXX; specialize (XXX _ _ eq_refl eq_refl).
          forward_reason.
          generalize (lambda_exprD_lift tus' x nil tvex tvs' x0).
          simpl. rewrite H3. intros; forwardy.
          eexists; split; [ eassumption | ].
          intros.
          etransitivity; [ | eapply (H7 us' Hnil vex vs') ].
          rewrite H4.
          eapply H5; eauto. }
        { generalize (HlookupV t (Var n) n); clear HlookupU HlookupV.
          autorewrite with exprD_rw in *; simpl in *.
          subst.
          forwardy.
          generalize H0.
          eapply nth_error_get_hlist_nth_appR in H0; eauto.
          simpl in *. forward_reason; inv_all; subst.
          Cases.rewrite_all_goal.
          destruct y.
          intro.
          intro XXX; specialize (XXX _ _ eq_refl eq_refl).
          forward_reason.
          generalize (lambda_exprD_lift tus' (Var (v - length tvex)) nil tvex tvs' x).
          simpl. rewrite H5. intros; forwardy.
          cutrewrite (v - length tvex + length tvex = v) in H7; [ | omega ].
          eexists; split; [ eassumption | ].
          intros.
          etransitivity; [ | eapply (H8 us' Hnil vex vs') ].
          rewrite H4.
          eapply H6; eauto. } }
      { intros.
        autorewrite with exprD_rw in *; simpl in *.
        forwardy.
        generalize (@nth_error_get_hlist_nth_appL _ typD tvs' _ _ H0).
        generalize (@nth_error_get_hlist_nth_appL _ typD tvs _ _ H0).
        clear H0.
        intros; forward_reason; inv_all; subst.
        revert H4 H0. Cases.rewrite_all_goal.
        destruct x0; destruct x1; simpl in *.
        intros; inv_all; subst.
        Cases.rewrite_all_goal.
        eexists; split; [ reflexivity | ].
        simpl. intros.
        Cases.rewrite_all_goal. reflexivity. } }
    { autorewrite with exprD_rw in *; simpl in *.
      forwardy.
      rewrite H. eexists; split; [ reflexivity | ].
      inv_all; subst.
      reflexivity. }
    { autorewrite with exprD_rw in *; simpl in *.
      forwardy.
      inv_all; subst.
      eapply IHe1 in H0; clear IHe1.
      eapply IHe2 in H1; clear IHe2.
      forward_reason.
      rewrite typeof_expr_subst' with (tvs := tvs) (tus := tus) (y := y); eauto.
      { rewrite H1; clear H1.
        rewrite H0; clear H0.
        eexists; split; [ reflexivity | ].
        unfold AbsAppI.exprT_App; intros; autorewrite_with_eq_rw.
        erewrite H2; eauto. erewrite H3; eauto. }
      { intros.
        assert (exists vD,
                  lambda_exprD tus tvs t0 e = Some vD)
          by (eapply ExprFacts.typeof_expr_lambda_exprD; eauto).
        destruct H6.
        consider (nth_error_get_hlist_nth typD tvs v); intros.
        { destruct s.
          assert (x2 = t0).
          { eapply nth_error_get_hlist_nth_Some in H7. destruct H7.
            clear - H4 x3. simpl in *. congruence. }
          subst.
          eapply HlookupV with (v := v) in H6; eauto.
          forward_reason. eapply ExprFacts.lambda_exprD_typeof_expr.
          eauto. }
        { clear - H4 H7; exfalso.
          eapply nth_error_get_hlist_nth_None in H7. congruence. } }
      { intros.
        assert (exists vD,
                  lambda_exprD tus tvs t0 e = Some vD)
          by (eapply ExprFacts.lambda_exprD_typeof_expr; eauto).
        destruct H6.
        consider (nth_error_get_hlist_nth typD tus u); intros.
        { destruct s.
          assert (x2 = t0).
          { eapply nth_error_get_hlist_nth_Some in H7. destruct H7.
            clear - H4 x3. simpl in *. congruence. }
          subst.
          eapply HlookupU with (v := u) in H6; eauto.
          forward_reason. eapply ExprFacts.lambda_exprD_typeof_expr.
          eauto. }
        { clear - H4 H7; exfalso.
          eapply nth_error_get_hlist_nth_None in H7. congruence. } } }
    { autorewrite with exprD_rw in *; simpl in *.
      match goal with
        | H : appcontext [ @typ2_match _ _ _ _ _ ?Y ] |- _ =>
          let H := fresh in
          destruct (@typ2_match_case _ _ _ _ _ Y) as [ [ ? [ ? [ ? H ] ] ] | H ];
            ( try rewrite H in * )
      end; clear H0.
      { unfold Relim in *. red in x1; subst.
        destruct (eq_sym (typ2_cast x x0)).
        forward.
        eapply IHe with (tvex := t :: tvex) in H0.
        forward_reason. simpl in *.
        rewrite H0.
        eexists; split; [ reflexivity | ].
        inv_all; subst.
        intros. eapply functional_extensionality.
        intros.
        eapply (H2 us vs us' vs' (Hcons (Rcast_val r x2) vex)); assumption. }
      { congruence. } }
    { generalize (HlookupU t (UVar u) u); clear HlookupU HlookupV.
      autorewrite with exprD_rw in *; simpl in *.
      forwardy.
      inv_all; subst.
      rewrite H. rewrite H0.
      intro HlookupU.
      destruct y.
      specialize (HlookupU _ _ eq_refl eq_refl).
      forward_reason.
      destruct (HNU u).
      { forward_reason.
        rewrite H3 in H1.
        specialize (H3 _ (lift 0 (length tvex)) (UVar u)).
        rewrite H3.
        generalize (lambda_exprD_lift tus' x1 nil tvex tvs' x); simpl.
        rewrite H1. intros.
        forwardy.
        eexists; split; [ eassumption | ].
        intros. etransitivity; [ eapply H2 | ]; eauto.
        eapply (H5 us' Hnil vex vs'). }
      { rewrite H3 in *.
        revert H1. autorewrite with exprD_rw; simpl.
        intros. forward.
        eexists; split; [ reflexivity | ].
        inv_all; subst; intros.
        eapply H2; eauto. } }
  Qed.

  Theorem lambda_exprD_subst
  : forall tus tvs tus' tvs' lookupU lookupV P (e : expr typ func) (t : typ),
      (forall u, Natural (lookupU u)) -> (forall v, Natural (lookupV v)) ->
      (forall t e v vD vD_orig,
         nth_error_get_hlist_nth _ tvs v = Some (@existT _ _ t vD) ->
         lambda_exprD tus tvs t e = Some vD_orig ->
         exists vD',
           lambda_exprD tus' tvs' t (lookupV v _ (fun x => x) e) = Some vD' /\
           forall us vs us' vs',
             P us vs us' vs' ->
             vD_orig us vs = vD vs ->
             vD vs = vD' us' vs') ->
      (forall t e v vD vD_orig,
         nth_error_get_hlist_nth _ tus v = Some (@existT _ _ t vD) ->
         lambda_exprD tus tvs t e = Some vD_orig ->
         exists vD',
           lambda_exprD tus' tvs' t (lookupU v _ (fun x => x) e) = Some vD' /\
           forall us vs us' vs',
             P us vs us' vs' ->
             vD_orig us vs = vD us ->
             vD us = vD' us' vs') ->
      forall tvx eD,
        lambda_exprD tus (tvx ++ tvs) t e = Some eD ->
      exists eD',
        lambda_exprD tus' (tvx ++ tvs') t (subst lookupU lookupV (length tvx) e) = Some eD' /\
        forall us vs us' vs' vx,
          P us vs us' vs' ->
          eD us (hlist_app vx vs) = eD' us' (hlist_app vx vs').
  Proof.
    intros.
    eapply (@lambda_exprD_subst' lookupU lookupV tus tvs tus' tvs' P)
      with (tvex := tvx) in H1; eauto.
  Qed.

  Definition mentions (uv : nat + nat) (e : expr typ func) : bool :=
    match uv with
      | inl u => _mentionsU u e
      | inr v => _mentionsV v e
    end.

  Lemma mentions_App
  : forall uv e1 e2,
      mentions uv (App e1 e2) =
      orb (mentions uv e1) (mentions uv e2).
  Proof. destruct uv; reflexivity. Qed.

  Definition lift_uv (uv : nat + nat) (n : nat) : nat + nat :=
    match uv with
      | inl u => inl u
      | inr v => inr (v + n)
    end.

  Lemma mentions_Abs
  : forall e uv t,
      mentions uv (Abs t e) = match uv with
                                | inl u => mentions (inl u) e
                                | inr v => mentions (inr (S v)) e
                              end.
  Proof.
    destruct uv; simpl; auto.
  Qed.

  Lemma mentions_Inj : forall x f, mentions x (Inj f) = false.
    destruct x; reflexivity.
  Qed.

  Lemma mentionsV_lift
  : forall n n0 (x : expr typ func) z,
      _mentionsV (z + n0 + n) (lift z n x) = _mentionsV (z + n0) x.
  Proof.
    induction x; simpl; intros; auto.
    { consider (v ?[ lt ] z).
      { intros.
        match goal with
          | |- ?X = ?Y =>
            consider X; consider Y; auto; try solve [ intros; exfalso ; omega ]
        end. }
      { intros.
        match goal with
          | |- ?X = ?Y =>
            consider X; consider Y; auto; try solve [ intros; exfalso ; omega ]
        end. intros.
        rewrite NPeano.Nat.add_cancel_r in H1. exfalso; auto. } }
    { rewrite IHx1. rewrite IHx2. reflexivity. }
    { specialize (IHx (S z)). apply IHx. }
  Qed.

  Lemma or_rearrange : forall (A B C D : Prop),
                         (A \/ B) \/ C \/ D <->
                         (A \/ C) \/ (B \/ D).
  Proof. clear; intuition. Qed.
  Lemma or_iff : forall A B C D : Prop,
                   (A <-> B) -> (C <-> D) ->
                   ((A \/ C) <-> (B \/ D)).
  Proof. clear. intuition. Qed.
  Lemma exists_or : forall (T : Type) (P Q : T -> Prop),
                      ((exists x : T, P x) \/ (exists x : T, Q x)) <->
                      (exists x, P x \/ Q x).
  Proof. clear. intuition; forward_reason; eauto.
         destruct H. left; eauto. right; eauto.
  Qed.
  Lemma exists_iff : forall (T : Type) (P Q : T -> Prop),
                       (forall x, P x <-> Q x) ->
                       ((exists x, P x) <-> (exists y, Q y)).
  Proof. clear. intuition; forward_reason; intuition eauto.
         eapply H in H0; eauto. eapply H in H0; eauto.
  Qed.
  Lemma or_factor : forall A B C : Prop,
                      ((A /\ B) \/ (A /\ C)) <-> A /\ (B \/ C).
  Proof. clear. intuition. Qed.

  Lemma false_eq_true_False : false = true <-> False.
  Proof. intuition. Qed.
  Lemma False_and : forall A, (False /\ A) <-> False.
  Proof. intuition. Qed.
  Lemma False_or : forall A, (False \/ A) <-> A.
  Proof. intuition. Qed.

End substitute.