Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Coq.Lists.List Coq.Program.Program
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.Common.ilist2
        Fiat.Common.i2list
        Fiat.Common.ilist3
        Fiat.Common.i3list.

Require Import Coq.Bool.Bool
        Coq.Strings.String
        Coq.Structures.OrderedTypeEx
        Coq.Arith.Arith
        Fiat.Common.String_as_OT
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.Common.DecideableEnsembles
        Fiat.Common.List.ListFacts
        Fiat.QueryStructure.Specification.Operations.FlattenCompList
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.QueryStructure.Implementation.Operations.General.InsertRefinements
        Fiat.QueryStructure.Implementation.Operations.General.EmptyRefinements
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations
        Fiat.QueryStructure.Implementation.ListImplementation
        Fiat.Common.List.PermutationFacts
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.BagADT
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.QueryStructureImplementation
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.IndexSearchTerms
        Fiat.QueryStructure.Implementation.Operations.General.DeleteRefinements.

Import Lists.List.ListNotations.

Section BagsQueryStructureRefinements.

  Import Vectors.Vector.VectorNotations.

  Variable qs_schema : RawQueryStructureSchema.
  Variable BagIndexKeys :
    ilist3 (B := fun ns => SearchUpdateTerms (rawSchemaHeading ns))
          (qschemaSchemas qs_schema).

  Lemma i2th_Bounded_Initialize_IndexedQueryStructure {n}
  : forall ns indices v idx,
      computes_to (@Initialize_IndexedQueryStructure n ns indices) v
      -> i3th v idx = Empty_set _.
  Proof.
    induction ns.
    - intros; inversion idx.
    - intros; revert ns IHns indices v H; pattern n, idx.
      match goal with
        |- ?P n idx => simpl; apply (@Fin.caseS P); intros; simpl in *
      end.
      + unfold CallBagConstructor in H; simpl in H; computes_to_inv.
        subst; simpl in *; eauto.
      + computes_to_inv; subst.
        eapply IHns; eauto.
  Qed.

  Corollary refine_QSEmptySpec_Initialize_IndexedQueryStructure
    : refine {nr' | DelegateToBag_AbsR (imap2 rawRel (Build_EmptyRelations (qschemaSchemas qs_schema))) nr'}
             (@Initialize_IndexedQueryStructure _ (qschemaSchemas qs_schema) BagIndexKeys).
  Proof.
    intros v Comp_v.
    computes_to_econstructor.
    unfold IndexedQueryStructure, DelegateToBag_AbsR, GetIndexedRelation.
    unfold GetUnConstrRelation.
    unfold DropQSConstraints, QSEmptySpec.
    intros; simpl; rewrite <- ith_imap2, ith_Bounded_BuildEmptyRelations,
                   i2th_Bounded_Initialize_IndexedQueryStructure; eauto.
    intros; eexists List.nil; split;
    intros; simpl; try rewrite <- ith_imap2, ith_Bounded_BuildEmptyRelations.
    - split; simpl; intros.
      + exists 0; unfold UnConstrFreshIdx; intros; intuition.
      + eexists List.nil; intuition eauto.
        * inversion H.
        * inversion H.
        * econstructor.
    - split; simpl; intros.
      + exists 0; unfold UnConstrFreshIdx; intros; intuition.
      + eexists List.nil; intuition eauto.
        * inversion H.
        * inversion H.
        * econstructor.
  Qed.

  Definition UpdateIndexedRelation
             (r_n : IndexedQueryStructure qs_schema BagIndexKeys) idx newRel
  : IndexedQueryStructure qs_schema BagIndexKeys  :=
    replace3_Index3 _ _ r_n idx newRel.

  Definition CallBagFind idx (r_n : IndexedQueryStructure qs_schema BagIndexKeys) st :=
    br <- CallBagMethod idx BagFind r_n st;
    ret (UpdateIndexedRelation r_n idx (fst br), snd br).

    Definition CallBagDelete idx (r_n : IndexedQueryStructure qs_schema BagIndexKeys) st :=
    br <- CallBagMethod idx BagDelete r_n st;
    ret (UpdateIndexedRelation r_n idx (fst br), snd br).

  Definition CallBagInsert idx (r_n : IndexedQueryStructure qs_schema BagIndexKeys) tup :=
    br <- CallBagMethod idx BagInsert r_n tup;
    ret (UpdateIndexedRelation r_n idx br).

  Definition CallBagEnumerate idx (r_n : IndexedQueryStructure qs_schema BagIndexKeys) :=
    br <- CallBagMethod idx BagEnumerate r_n;
    ret (UpdateIndexedRelation r_n idx (fst br), snd br).

  Lemma get_update_indexed_eq :
    forall (r_n : IndexedQueryStructure qs_schema BagIndexKeys) idx newRel,
      GetIndexedRelation (UpdateIndexedRelation r_n idx newRel) idx = newRel.
  Proof.
    unfold UpdateIndexedRelation, GetIndexedRelation;
    intros; simpl; rewrite i3th_replace_Index_eq; eauto using string_dec.
  Qed.

  Lemma get_update_indexed_neq :
    forall (r_n : IndexedQueryStructure qs_schema BagIndexKeys) idx idx' newRel,
      idx <> idx'
      -> GetIndexedRelation (UpdateIndexedRelation r_n idx newRel) idx' =
         GetIndexedRelation r_n idx'.
  Proof.
    unfold UpdateIndexedRelation, GetIndexedRelation;
    intros; simpl; rewrite i3th_replace_Index_neq; eauto using string_dec.
  Qed.

  Lemma exists_UnConstrFreshIdx
    : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall idx,
        exists bnd,
          UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd.
  Proof.
    unfold DelegateToBag_AbsR; intros.
    destruct (H idx) as
        [l [ [ [bnd fresh_bnd] [l' [l'_eq [l_eqv NoDup_l'] ] ] ]
              [ [bnd' fresh_bnd'] [l'' [l''_eq [l''_eqv NoDup_l''] ] ] ] ] ];
      eauto.
  Qed.

  Lemma refine_Pick_UnConstrFreshIdx
    : forall r_o
             (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall idx bnd,
        UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd
      -> refine { bnd | UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd}
                (ret bnd).
  Proof.
    intros; refine pick val bnd; eauto.
    reflexivity.
  Qed.

  Lemma refine_Query_In_Enumerate
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall (idx : Fin.t _)
                (resultComp : RawTuple -> Comp (list ResultT)),
           refine (UnConstrQuery_In r_o idx resultComp)
                  (l <- Join_Comp_Lists [ inil2 ]
                     (fun _ =>
                        l <- CallBagEnumerate idx r_n;
                      (ret (snd l)));
                   (List_Query_In l (fun tup : ilist2 (B := @RawTuple) [ _ ]=> resultComp (ilist2_hd tup)))) .
  Proof.
    unfold UnConstrQuery_In, QueryResultComp, CallBagEnumerate,
    CallBagMethod;
    intros; simpl.
    setoid_rewrite refineEquiv_bind_bind;
      setoid_rewrite refineEquiv_bind_unit; simpl.
    unfold List_Query_In.
    intros v Comp_v;  computes_to_inv;
    unfold EnsembleIndexedListEquivalence,
    UnIndexedEnsembleListEquivalence in *.
    destruct (H idx); intuition; destruct_ex; intuition; subst.
    unfold EnsembleIndexedListEquivalence,
    UnIndexedEnsembleListEquivalence in *;
      intuition; destruct_ex; intuition; subst.
    computes_to_econstructor.
    instantiate (1 := map indexedElement x0);
      computes_to_econstructor; eauto.
    setoid_rewrite H0 in H8.
    setoid_rewrite H4.
    revert H6 H8 H11 H5 H10; clear; intros.
    apply NoDup_Permutation in H8; eauto using NoDup_IndexedElement.
    destruct (@permu_exists _ (map indexedElement x0) x4);
      intuition.
    simpl in *; unfold GetNRelSchema in *; rewrite <- H5.
    eapply Permutation_map; eauto.
    setoid_rewrite <- H1.
    eexists x; intuition eauto.
    eapply Permutation_map in H1.
    symmetry in H1.
    eapply NoDup_Permutation_rewrite; eauto.
    rewrite map_map.
    first [ rewrite !map_app, !map_map, !app_nil_r in Comp_v'';
            simpl in *; rewrite map_map in Comp_v''; eauto
          | repeat setoid_rewrite map_app in Comp_v'';
            repeat setoid_rewrite map_map in Comp_v''; simpl in *;
            rewrite app_nil_r in Comp_v''; eauto
          ].
  Qed.

  Local Opaque IndexedQueryStructure.

  Lemma refine_Filtered_Query_In_Enumerate
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall (idx : Fin.t _)
                (resultComp : RawTuple -> Comp (list ResultT)),
           refine (UnConstrQuery_In r_o idx resultComp)
                  (l <- Join_Filtered_Comp_Lists [ inil2 ]
                     (fun _ =>
                        l <- CallBagEnumerate idx r_n;
                      (ret (snd l)))
                     (fun _ => true);
                   (List_Query_In l (fun tup : ilist2 (B := @RawTuple) [ _ ]=> resultComp (ilist2_hd tup)))) .
  Proof.
    intros; rewrite refine_Query_In_Enumerate by eauto.
    rewrite Join_Filtered_Comp_Lists_id; reflexivity.
  Qed.

  Local Transparent Query_For.

  Lemma refine_For_Enumerate
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall (idx : Fin.t _)
                (f : _ -> Comp (list ResultT)),
           refine (For (l <- CallBagEnumerate idx r_n;
                        f l))
                  (l <- CallBagEnumerate idx r_n;
                   For (f l)).
  Proof.
    simpl; intros; unfold Query_For.
    simplify with monad laws.
    unfold CallBagEnumerate, CallBagMethod; simpl.
    unfold refine; intros;  computes_to_inv.
    subst; repeat computes_to_econstructor; eauto.
  Qed.

  Lemma refine_Join_Query_In_Enumerate'
        {n}
        headings
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      forall (idx : Fin.t _)
             (resultComp : ilist2 (n := n) (B:= @RawTuple) headings
                           -> RawTuple
                           -> Comp (list ResultT))
             l,
        refine (List_Query_In l (fun tup : ilist2 (B := @RawTuple) headings =>
                                   UnConstrQuery_In r_o idx (resultComp tup)))
               (l' <- (Join_Comp_Lists l (fun _ => l <- (CallBagEnumerate idx r_n);
                                          ret (snd l)));
                List_Query_In l' (fun tup_pair => (resultComp (ilist2_tl tup_pair) (ilist2_hd tup_pair)))).
  Proof.
    intros.
    unfold List_Query_In; induction l; unfold Join_Comp_Lists; simpl.
    - intros v Comp_v;  computes_to_inv; subst; eauto.
    - setoid_rewrite IHl; rewrite refine_Query_In_Enumerate; eauto.
      unfold List_Query_In.
      setoid_rewrite refineEquiv_bind_bind at 1.
      setoid_rewrite refineEquiv_bind_bind at 2.
      intros v Comp_v;  computes_to_inv.
      subst.
      rewrite map_app, map_map in Comp_v'; simpl in *.
      computes_to_econstructor; eauto.
      apply flatten_CompList_app_inv' in Comp_v'; destruct_ex; intuition.
      subst; repeat (computes_to_econstructor; eauto).
      unfold Build_single_Tuple_list in *.
      rewrite !map_app, !map_map, app_nil_r; simpl; eauto.
  Qed.

  Corollary refine_Join_Query_In_Enumerate
            (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      forall (idx idx' : Fin.t _)
             (resultComp : RawTuple -> RawTuple -> Comp (list ResultT)),
        refine (l <- CallBagEnumerate idx r_n;
                List_Query_In (Build_single_Tuple_list (snd l))
                              (fun tup =>
                                 UnConstrQuery_In r_o idx' (resultComp (ilist2_hd tup))))
               (l <- CallBagEnumerate idx r_n;
                l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd l))
                                       (fun _ => l <- (CallBagEnumerate idx' r_n);
                                        ret (snd l)));
                List_Query_In l' (fun tup_pair => (resultComp (ilist2_hd (ilist2_tl tup_pair)) (ilist2_hd tup_pair)))).
  Proof.
    intros.
    apply refine_bind; [reflexivity
                       | simpl; intro ].
    eapply refine_Join_Query_In_Enumerate' with
    (l := Build_single_Tuple_list (snd a)); eauto.
  Qed.

  Corollary refine_Filtered_Join_Query_In_Enumerate'
            {n}
        headings
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      forall (idx : Fin.t _)
             (resultComp : ilist2 (n := n) ( B:= @RawTuple) headings
                           -> RawTuple
                           -> Comp (list ResultT))
             l,
        refine (List_Query_In l (fun tup : ilist2 (B:= @RawTuple) headings =>
                                   UnConstrQuery_In r_o idx (resultComp tup)))
               (l' <- (Join_Filtered_Comp_Lists l (fun _ => l <- (CallBagEnumerate idx r_n );
                                                   ret (snd l))
                                                (fun _ => true));
                List_Query_In l' (fun tup_pair => (resultComp (ilist2_tl tup_pair) (ilist2_hd tup_pair)))).
  Proof.
    intros; rewrite refine_Join_Query_In_Enumerate' by eauto.
    rewrite Join_Filtered_Comp_Lists_id; reflexivity.
  Qed.

  Corollary refine_Filtered_Join_Query_In_Enumerate
            (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      forall (idx idx' : Fin.t _)
             (resultComp : RawTuple -> RawTuple -> Comp (list ResultT)),
        refine (l <- CallBagEnumerate idx r_n ;
                List_Query_In (Build_single_Tuple_list (snd l))
                              (fun tup =>
                                 UnConstrQuery_In r_o idx' (resultComp (ilist2_hd tup))))
               (l <- CallBagEnumerate idx r_n ;
                l' <- (Join_Filtered_Comp_Lists (Build_single_Tuple_list (snd l))
                                       (fun _ => l <- (CallBagEnumerate idx' r_n );
                                        ret (snd l))
                                       (fun _ => true));
                List_Query_In l' (fun tup_pair => (resultComp (ilist2_hd (ilist2_tl tup_pair)) (ilist2_hd tup_pair)))).
  Proof.
    intros; rewrite refine_Join_Query_In_Enumerate by eauto.
    apply refine_bind; [reflexivity
                       | intro; rewrite Join_Filtered_Comp_Lists_id; reflexivity].
  Qed.

  (*Lemma refine_Join_Enumerate_Swap
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      forall (idx idx' : BoundedString)
             (resultComp : _ -> Comp (list ResultT)),
        refine (l <- CallBagEnumerate idx r_n ;
                l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd l))
                                       (fun _ => l <- (CallBagEnumerate idx' r_n );
                                        ret (snd l)));
                List_Query_In l' resultComp)
               (l <- CallBagEnumerate idx' r_n ;
                l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd l))
                                       (fun _ => l <- (CallBagEnumerate idx r_n );
                                        ret (snd l)));
                List_Query_In l' (fun tup_pair => (resultComp (icons _ (ilist2_hd (ilist2_tl tup_pair)) (icons _ (ilist2_hd tup_pair) (inil _)))))).
  Proof.
  Admitted. *)

  (* Lemma refine_Join_Enumerate_Swap
        (A B ResultT : Type) :
    forall (c : Comp A) (c' : Comp B)
           (resultComp : _ -> _ -> Comp (list ResultT)),
      refineEquiv (For (l <- c;
                        l' <- c';
                        resultComp l l'))
                  (For (l' <- c';
                        l <- c;
                        resultComp l l')).
  Proof.
    split; simpl; intros; f_equiv; intros v Comp_v;
     computes_to_inv; subst;
    repeat (econstructor; eauto).
  Qed.*)

  Lemma refine_BagFind_filter
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      ->
      forall (idx : Fin.t _)
             filter_dec
             search_pattern,
        ExtensionalEq filter_dec
                      (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)
        -> refine (l <- {l | EnsembleIndexedListEquivalence (GetIndexedRelation r_n idx) l};
                   ret (r_n, filter filter_dec l))
                  (CallBagFind idx r_n search_pattern).
  Proof.
    unfold UnConstrQuery_In, QueryResultComp, CallBagEnumerate,
    CallBagFind, CallBagMethod, Query_For;
    intros; simpl.
    repeat setoid_rewrite refineEquiv_bind_bind;
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
    setoid_rewrite (filter_by_equiv _ _ H0).
    intros v Comp_v.
    computes_to_inv.
    destruct (H idx) as [l [? ?] ].
    destruct H2.
    pose proof (UnIndexedEnsembleListEquivalence_filter
                  (DecideableEnsemble_bool (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)) H3).
    destruct Comp_v as [? ?].
    pose proof (Permutation_UnIndexedEnsembleListEquivalence' H4 H6).
    apply permutation_filter in H7; destruct H7 as [l' [? ? ] ]; subst.
    repeat computes_to_econstructor.
    econstructor; [eauto | ].
    eapply Permutation_UnIndexedEnsembleListEquivalence; eauto.
    unfold UpdateIndexedRelation, GetIndexedRelation.
    rewrite replace3_Index3_eq.
    computes_to_econstructor.
  Qed.

    Lemma refine_filter_BagFind
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      ->
      forall (idx : Fin.t _)
             filter_dec
             search_pattern,
        ExtensionalEq filter_dec
                      (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)
        -> refine (CallBagFind idx r_n search_pattern)
                  (l <- {l | EnsembleIndexedListEquivalence (GetIndexedRelation r_n idx) l};
                   ret (r_n, filter filter_dec l)).
  Proof.
    unfold UnConstrQuery_In, QueryResultComp, CallBagEnumerate,
    CallBagFind, CallBagMethod, Query_For;
    intros; simpl.
    repeat setoid_rewrite refineEquiv_bind_bind;
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
    setoid_rewrite (filter_by_equiv _ _ H0).
    intros v Comp_v.
    computes_to_inv.
    subst.
    destruct Comp_v as [? ?].
    pose proof (UnIndexedEnsembleListEquivalence_filter
                  (DecideableEnsemble_bool (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)) H2).
    repeat computes_to_econstructor.
    eexists; eauto.
    destruct H1 as [? H1]; eexists; intros ? ?; try eapply H1.
    apply H4.
    unfold UpdateIndexedRelation, GetIndexedRelation.
    rewrite replace3_Index3_eq.
    computes_to_econstructor.
  Qed.

  Lemma refine_Query_For_In_Find
        (ResultT : Type)
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      ->
      forall (idx : Fin.t _)
             filter_dec
             search_pattern
             (resultComp : RawTuple -> Comp (list ResultT)),
        ExtensionalEq filter_dec
                      (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)
        -> refine (l <- CallBagEnumerate idx r_n ;
                   List_Query_In (filter filter_dec (snd l)) resultComp)
                  (l <- CallBagFind idx r_n search_pattern;
                   List_Query_In (snd l) resultComp).
  Proof.
    intros. setoid_rewrite <- refine_BagFind_filter; eauto.
    unfold UnConstrQuery_In, QueryResultComp, CallBagEnumerate,
    CallBagFind, CallBagMethod, Query_For;
    intros; simpl.
    simplify with monad laws.
    repeat setoid_rewrite refineEquiv_bind_bind;
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
    reflexivity.
  Qed.

  Lemma refine_Join_Comp_Lists_To_Find {n}
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall {headings}
                (l1 : list (ilist2 (n := n) (B:= @RawTuple) headings))
                (idx : Fin.t _)
                search_pattern,
           refine (Join_Filtered_Comp_Lists l1
                                            (fun _ =>
                                               l <- CallBagEnumerate idx r_n ;
                                             ret (snd l))
                                            (fun a => BagMatchSearchTerm (ith3  BagIndexKeys idx) search_pattern (ilist2_hd a) && true))
                  (Join_Comp_Lists l1
                                   (fun _ =>
                                      l <- CallBagFind idx r_n search_pattern;
                                    ret (snd l))) .
  Proof.
    unfold Join_Filtered_Comp_Lists, Join_Comp_Lists; intros; simpl.
    induction l1.
    - simpl; simplify with monad laws; reflexivity.
    - Local Transparent CallBagMethod.
      simpl.
        setoid_rewrite refineEquiv_bind_bind.
        setoid_rewrite refineEquiv_bind_bind.
        etransitivity;
          [ | apply refine_bind;
              [ eapply (@refine_BagFind_filter _ _ H idx (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern) search_pattern); unfold ExtensionalEq; intuition
              | unfold pointwise_relation; intros; finish honing] ].
        setoid_rewrite refineEquiv_bind_bind.
        setoid_rewrite refineEquiv_bind_bind at 1.
        setoid_rewrite refineEquiv_bind_bind at 1.
        setoid_rewrite refineEquiv_bind_bind at 1.
        repeat setoid_rewrite refineEquiv_bind_unit; simpl;
        f_equiv; intro.
        intros v Comp_v.
        computes_to_inv; subst.
        generalize (IHl1 _ Comp_v); intros;  computes_to_inv.
        computes_to_econstructor; subst; eauto.
        rewrite filter_app, ListFacts.filter_map.
        simpl.
        erewrite filter_by_equiv; eauto.
        unfold ExtensionalEq; intros; rewrite andb_true_r; auto.
  Qed.

  Lemma refine_Join_Comp_Lists_To_Find_dep {n}
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall {headings}
                (l1 : list (ilist2 (n := n) (B:= @RawTuple) headings))
                (idx :Fin.t _)
                (search_pattern : ilist2 (B:= @RawTuple) headings -> _),
           refine (Join_Filtered_Comp_Lists l1
                                            (fun _ =>
                                               l <- CallBagEnumerate idx r_n ;
                                             ret (snd l))
                                            (fun a => BagMatchSearchTerm (ith3  BagIndexKeys idx)
                                                                         (search_pattern (ilist2_tl a)) (ilist2_hd a) && true))
                  (Join_Comp_Lists l1
                                   (fun a =>
                                      l <- CallBagFind idx r_n (search_pattern a);
                                    ret (snd l))) .
  Proof.
    unfold Join_Filtered_Comp_Lists, Join_Comp_Lists; intros; simpl.
    induction l1.
    - simpl; simplify with monad laws; reflexivity.
    - Local Transparent CallBagMethod.
      unfold CallBagMethod.
      simpl.
      setoid_rewrite refineEquiv_bind_bind.
      setoid_rewrite refineEquiv_bind_bind.
      etransitivity;
        [ | apply refine_bind;
            [ eapply (@refine_BagFind_filter _ _ H idx (BagMatchSearchTerm (ith3 BagIndexKeys idx) (search_pattern a)) (search_pattern a)); unfold ExtensionalEq; intuition
            | unfold pointwise_relation; intros; finish honing] ].
      setoid_rewrite refineEquiv_bind_bind.
      setoid_rewrite refineEquiv_bind_bind at 1.
      setoid_rewrite refineEquiv_bind_bind at 1.
      repeat setoid_rewrite refineEquiv_bind_unit; simpl;
      f_equiv; intro.
      setoid_rewrite refineEquiv_bind_bind at 1.
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
      intros v Comp_v.
       computes_to_inv; subst.
      generalize (IHl1 _ Comp_v); intros;  computes_to_inv.
      computes_to_econstructor; subst; eauto.
      rewrite filter_app, ListFacts.filter_map.
      simpl.
      erewrite filter_by_equiv; eauto.
      unfold ExtensionalEq; intros; rewrite andb_true_r; auto.
  Qed.

  Instance DecideableEnsemblePair_tail
           {n}
           {A}
           {a}
           {As}
           (f : A -> Type)
           (P : Ensemble (ilist2 (n := n) (B := f) As))
           (P_dec : DecideableEnsemble P)
    : DecideableEnsemble (fun ab : ilist2 (B := f) (a :: As) => P (ilist2_tl ab)).
  Proof.
    apply Build_DecideableEnsemble with (fun ab => DecideableEnsembles.dec (ilist2_tl ab)).
    intro; apply (dec_decides_P (DecideableEnsemble := P_dec) (ilist2_tl a0)).
  Defined.

  Instance DecideableEnsemblePair_head
           {n}
           {A}
           {a}
           {As}
           (f : A -> Type)
           (P : Ensemble (f a))
           (P_dec : DecideableEnsemble P)
    : DecideableEnsemble (fun ab : ilist2 (n := S n) (B := f) (a :: As) => P (ilist2_hd ab)).
  Proof.
    apply Build_DecideableEnsemble with (fun ab => DecideableEnsembles.dec (ilist2_hd ab)).
    intro; apply (dec_decides_P (DecideableEnsemble := P_dec) (ilist2_hd a0)).
  Defined.

  Lemma Join_Comp_Lists_nil
        {n}
        {A}
        {a}
        {As}
        (f' : A -> Type)
  : forall (s2 : _ -> Comp (list (f' a))),
      refineEquiv (Join_Comp_Lists (n := n) (As := As) (a := a) (List.nil) s2) (ret (List.nil)).
  Proof.
    unfold Join_Comp_Lists; simpl; try reflexivity.
  Qed.

  Lemma filter_and_join_ilist2_hd
        {n}
        {A}
        {a}
        {As}
        (f' : A -> Type)
  : forall
      (f : f' a -> bool)
      (s1 : list (ilist2 (n := n) (B := f') As))
      (s2 : _ -> Comp (list (f' a)))
      filter_rest ,
      refineEquiv (l <- (Join_Comp_Lists s1 s2);
                   ret (filter (fun x : ilist2 (B := f') (a :: As) => f (ilist2_hd x) && filter_rest x) l))
                  (l <- Join_Comp_Lists s1 (fun a => l <- s2 a; ret (filter f l));
                   ret (filter filter_rest l)).
  Proof.
    split; induction s1; unfold Join_Comp_Lists in *; simpl in *; intros; eauto.
    - simplify with monad laws; rewrite refineEquiv_bind_unit;
      reflexivity.
    - simplify with monad laws; intros v Comp_v;
       computes_to_inv; subst; computes_to_econstructor; eauto.
      pose (IHs1 _ (BindComputes _ (fun x => ret (filter filter_rest x)) _ _ Comp_v'0 (ReturnComputes _))).
       computes_to_inv; subst.
      repeat (computes_to_econstructor; eauto).
      repeat rewrite filter_app, ListFacts.filter_map; simpl; eauto.
      rewrite <- filter_and, c'; eauto.
    - intros v Comp_v;  computes_to_inv; subst; eauto.
    - simplify with monad laws; intros v Comp_v;
       computes_to_inv; subst; computes_to_econstructor; eauto.
      pose proof (IHs1 _ (BindComputes _ (fun x => ret (_ x)) _ _ Comp_v'0 (ReturnComputes _))).
       computes_to_inv; subst.
      repeat (computes_to_econstructor; eauto).
      rewrite filter_app, ListFacts.filter_map; simpl; eauto.
      repeat rewrite filter_app, ListFacts.filter_map; simpl; eauto.
      rewrite <- filter_and, H'; eauto.
  Qed.

  Corollary filter_join_ilist2_hd
            {n}
            {A}
            {a}
            {As}
            (f' : A -> Type)
  : forall
      (f : f' a -> bool)
      (s1 : list (ilist2 (B := f') As))
      (s2 : _ -> Comp (list (f' a))),
      refineEquiv (l <- (Join_Comp_Lists s1 s2);
                   ret (filter (fun x : ilist2 (n := S n) (B := f') (a :: As) => f (ilist2_hd x)) l))
                  (Join_Comp_Lists s1 (fun a => l <- s2 a; ret (filter f l))).
  Proof.
    intros; pose proof (filter_and_join_ilist2_hd f s1 s2 (fun _ => true)).
    setoid_rewrite filter_and in H; setoid_rewrite filter_true in H.
    setoid_rewrite H; eauto; setoid_rewrite refineEquiv_unit_bind; reflexivity.
  Qed.

  Lemma filter_Build_single_Tuple_list
        {heading}
        (l : list (@RawTuple heading))
        (filter_dec : @RawTuple heading -> bool)
  : filter (fun tup : ilist2 (B:= @RawTuple) [_] => filter_dec (ilist2_hd tup)) (Build_single_Tuple_list l) = Build_single_Tuple_list (filter filter_dec l).
  Proof.
    induction l; simpl; eauto.
    destruct (filter_dec a); simpl; eauto.
    f_equal; eauto.
  Qed.

  Corollary refine_Query_For_In_Find_snd'
            (ResultT : Type)
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      ->
      forall (idx :Fin.t _)
             (filter_dec : RawTuple -> bool)
             search_pattern
             (resultComp : _ -> Comp (list ResultT)),
        ExtensionalEq filter_dec
                      (BagMatchSearchTerm (ith3  BagIndexKeys idx) search_pattern)
        -> refine (l <- CallBagEnumerate idx r_n ;
                   List_Query_In (filter (fun tup : ilist2 (B:= @RawTuple) [_] => filter_dec (ilist2_hd tup)) (Build_single_Tuple_list (snd l)))
                                 resultComp)
                  (l <- CallBagFind idx r_n search_pattern;
                   List_Query_In (Build_single_Tuple_list (snd l)) resultComp).
  Proof.
    simpl; intros.
    setoid_rewrite <- refine_BagFind_filter; eauto.
    setoid_rewrite filter_Build_single_Tuple_list.
    unfold UnConstrQuery_In, QueryResultComp, CallBagMethod,
    CallBagFind, CallBagEnumerate, Query_For;
      intros; simpl.
    simplify with monad laws.
    repeat setoid_rewrite refineEquiv_bind_bind;
      repeat setoid_rewrite refineEquiv_bind_unit; simpl; f_equiv; intro.
  Qed.

  Corollary refine_Query_For_In_Find_single
            (ResultT : Type)
  : forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      forall (idx :Fin.t _)
             search_pattern
             (resultComp : _ -> Comp (list ResultT))
             filter_rest,
        refine (l <- CallBagEnumerate idx r_n ;
                List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) [_] => BagMatchSearchTerm _ search_pattern (ilist2_hd a) && filter_rest a) (Build_single_Tuple_list (snd l)))
                              resultComp)
               (l <- CallBagFind idx r_n search_pattern;
                List_Query_In (filter filter_rest (Build_single_Tuple_list (snd l))) resultComp).
  Proof.
    simpl; intros.
    setoid_rewrite <- refine_BagFind_filter; eauto.
    unfold CallBagMethod, CallBagEnumerate, CallBagFind; simpl; intros.
    simplify with monad laws.
    repeat setoid_rewrite refineEquiv_bind_bind;
      repeat setoid_rewrite refineEquiv_bind_unit; simpl;
      f_equiv; intro.
    setoid_rewrite <- filter_Build_single_Tuple_list; rewrite filter_and;
    f_equiv.
    intro; reflexivity.
  Qed.

  Add Parametric Morphism
      (n : nat)
      (A : Type)
      (f : A -> Type)
      (As : Vector.t A n)
      (a : A)
      (l' : list (ilist2 (B := f) As))
  : (@Join_Comp_Lists n A f As a l')
      with signature
      (pointwise_relation _ refineEquiv) ==> refineEquiv
        as refineEquiv_Join_Comp_Lists.
  Proof.
    unfold pointwise_relation; simpl; intros.
    induction l'; unfold Join_Comp_Lists; simpl.
    - reflexivity.
    - rewrite H; setoid_rewrite IHl'; reflexivity.
  Qed.

  Lemma Join_Comp_Lists_apply_f
        {n}
        {A B C : Type}
        {f : A -> Type}
  : forall (As : Vector.t A n)
           (a : A)
           (l : list (ilist2 (B := f) As))
           (c : ilist2 (B := f) As -> Comp (list (f a)))
           (c' : B -> Comp C) (f' : list (ilist2 (B := f) (a :: As)) -> B),
      refineEquiv (l' <- Join_Comp_Lists l c;
                   c' (f' l'))
                  (l' <- (l' <- Join_Comp_Lists l c; ret (f' l'));
                   c' l').
  Proof.
    split; rewrite refineEquiv_bind_bind;
    setoid_rewrite refineEquiv_bind_unit;
    intros v Comp_v;  computes_to_inv;
    try econstructor; eauto.
  Qed.

  (*Lemma refine_Join_Comp_Lists_filter_search_term_snd
        {n}
        (ResultT : Type) :
    forall (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           headings
           idx'
           search_pattern
           (resultComp : ilist2 (B:= @RawTuple) (_ :: headings) -> Comp (list ResultT))
           filter_rest
           cl,
      refine (l' <- (Join_Comp_Lists (n := n) cl
                                     (fun _ => l <- CallBagEnumerate idx' r_n ;
                                      ret (snd l)));
              List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) (_ :: headings) => BagMatchSearchTerm _ search_pattern (ilist2_hd a) && filter_rest a) l')
                            resultComp)
             (l' <- (Join_Comp_Lists cl
                                     (fun _ => l <- CallBagFind idx' r_n search_pattern;
                                      ret (snd l)));
              List_Query_In (filter filter_rest l') resultComp).
  Proof.
    intros; unfold CallBagMethod, CallBagEnumerate; simpl.
    setoid_rewrite <- (refineEquiv_BagFind_filter H); eauto.
    setoid_rewrite <-
    repeat setoid_rewrite (refineEquiv_bind_bind);
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
    match goal with
      |- refine (l' <- Join_Comp_Lists ?l ?c; (@?f l')) _ =>
      setoid_rewrite (Join_Comp_Lists_apply_f l c) with (c' := fun l => List_Query_In l _)
    end.
    setoid_rewrite refineEquiv_unit_bind.
    rewrite (filter_and_join_ilist2_hd
               (As := headings) (f' := @RawTuple)
               (BagMatchSearchTerm _ search_pattern)
               cl
               (fun _ : ilist2 (B:= @RawTuple) headings =>
                  {l : list RawTuple |
                   EnsembleIndexedListEquivalence (GetIndexedRelation r_n idx') l})).
    simplify with monad laws; f_equiv.
  Qed.

  Corollary refine_Join_Comp_Lists_filter_search_term_snd'
            (ResultT : Type) :
    forall (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           idx idx'
           search_pattern
           (resultComp : ilist2 (B:= @RawTuple) [_; _] -> Comp (list ResultT))
           filter_rest,
      refine (cl <- CallBagEnumerate idx r_n ;
              l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd cl))
                                     (fun _ => l <- CallBagEnumerate idx' r_n ;
                                      ret (snd l)));
              List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) [_ ; _] => BagMatchSearchTerm _ search_pattern (ilist2_hd a) && filter_rest a) l')
                            resultComp)
             (cl <- CallBagEnumerate idx r_n ;
              l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd cl))
                                     (fun _ => l <- CallBagFind idx' r_n search_pattern;
                                      ret (snd l)));
              List_Query_In (filter filter_rest l') resultComp).
  Proof.
    intros; apply refine_bind; [reflexivity | intro].
    apply refine_Join_Comp_Lists_filter_search_term_snd.
  Qed. *)

  Lemma refine_List_Query_In_Return
        (ElementT ResultT : Type):
    forall (l : list ElementT)
           (f : ElementT -> ResultT),
      refine (List_Query_In l (fun el => Query_Return (f el)) ) (ret (map f l)).
  Proof.
    unfold List_Query_In; induction l; intros; simpl.
    - reflexivity.
    - unfold Query_Return; simplify with monad laws;
      setoid_rewrite IHl; simplify with monad laws;
      reflexivity.
  Qed.

  Lemma filter_and_join_ilist2_hd_dep
        {n}
        {A}
        {a}
        {As : Vector.t A n}
        (f' : A -> Type)
  : forall
      (f : ilist2 (B := f') As -> f' a -> bool)
      (s1 : list (ilist2 (B := f') As))
      (s2 : _ -> Comp (list (f' a)))
      filter_rest,
      refineEquiv (l <- (Join_Comp_Lists s1 s2);
                   ret (filter (fun x : ilist2 (B := f') (a :: As) => f (ilist2_tl x) (ilist2_hd x) && filter_rest x) l))
                  (l <- Join_Comp_Lists s1 (fun a => l <- s2 a; ret (filter (f a) l));
                   ret (filter filter_rest l)).
  Proof.
    split; induction s1; unfold Join_Comp_Lists in *; simpl in *; intros; eauto.
    - simplify with monad laws; rewrite refineEquiv_bind_unit; reflexivity.
    - simplify with monad laws; intros v Comp_v;
       computes_to_inv; subst; computes_to_econstructor; eauto.
      pose (IHs1 _ (BindComputes _ (fun x => ret (_ x)) _ _ Comp_v'0 (ReturnComputes _))).
       computes_to_inv; subst.
      repeat (computes_to_econstructor; eauto).
      repeat rewrite filter_app, ListFacts.filter_map; simpl; eauto.
      rewrite <- filter_and, c'; eauto.
    - intros v Comp_v;  computes_to_inv; subst; eauto.
    - simplify with monad laws; intros v Comp_v;
       computes_to_inv; subst; computes_to_econstructor; eauto.
      pose proof (IHs1 _ (BindComputes _ (fun x => ret (_ x)) _ _ Comp_v'0 (ReturnComputes _))).
       computes_to_inv; subst.
      repeat (computes_to_econstructor; eauto).
      rewrite filter_app, ListFacts.filter_map; simpl; eauto.
      repeat rewrite filter_app, ListFacts.filter_map; simpl; eauto.
      rewrite <- filter_and, H'; eauto.
  Qed.

  Lemma refine_Join_Comp_Lists_filter_search_term_snd_dep
        {n}
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           (_ : DelegateToBag_AbsR r_o r_n)
           (headings : Vector.t _ n)
           idx'
           (search_pattern : _ -> _)
           (resultComp : ilist2 (B:= @RawTuple) (_ :: headings) -> Comp (list ResultT))
           filter_rest
           (cl : list (ilist2 (B:= @RawTuple) headings)),
      refine (l' <- (Join_Comp_Lists cl
                                     (fun _ => l <- CallBagEnumerate idx' r_n ;
                                      ret (snd l)));
              List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) (_ :: headings) => BagMatchSearchTerm _ (search_pattern (ilist2_tl a)) (ilist2_hd a) && filter_rest a) l')
                            resultComp)
             (l' <- (Join_Comp_Lists cl
                                     (fun tup => l <- CallBagFind idx' r_n (search_pattern tup);
                                      ret (snd l)));
              List_Query_In (filter filter_rest l') resultComp).
  Proof.
    intros; unfold CallBagMethod; simpl.
    etransitivity;
      [
      | rewrite <- refine_Join_Comp_Lists; [reflexivity |
                                            intro;
                                              setoid_rewrite <- (@refine_BagFind_filter _ _ H idx' (BagMatchSearchTerm (ith3 BagIndexKeys idx') (search_pattern a)) (search_pattern a)); [finish honing | intro; reflexivity] ] ].
    repeat setoid_rewrite (refineEquiv_bind_bind);
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
    match goal with
      |- refine (l' <- @Join_Comp_Lists ?n ?A ?f ?As ?a ?l ?c ; _) _ =>
      pose proof (fun B C => @Join_Comp_Lists_apply_f n A B C f As a l c) as H'';
        setoid_rewrite H''
    end.
    setoid_rewrite refineEquiv_unit_bind.
    etransitivity.
    2: unfold List_Query_In; etransitivity.
    Focus 3.
    (* 3: { *)
      apply refine_under_bind.
      intros; set_evars.
      rewrite <- refineEquiv_bind_unit with (f := fun x => flatten_CompList (map resultComp x))
                                            (x := filter filter_rest a).
      unfold H1; finish honing.
    (* } *)
    Focus 2.
    (* 2: { *)
         simpl.
         rewrite <- refine_bind_bind.
         rewrite <- filter_and_join_ilist2_hd_dep with
             (f := fun tup =>  (BagMatchSearchTerm (ith3 BagIndexKeys idx')
                                                   (search_pattern tup)))
             (filter_rest0 := filter_rest).
         finish honing.
    (* } *)
    simplify with monad laws.
    rewrite refineEquiv_bind_bind.
    setoid_rewrite refineEquiv_bind_unit.
    f_equiv.
  Qed.

  Lemma realizeable_Enumerate
  : forall
      (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
      (r_o : UnConstrQueryStructure qs_schema)
      idx,
      DelegateToBag_AbsR r_o r_n ->
      exists v : list RawTuple,
        refine
          (l <- CallBagEnumerate idx r_n ;
           ret (snd l))
          (ret v).
  Proof.
    intros; destruct (H idx) as [l [l_eqv l_eqv'] ].
    Local Transparent CallBagMethod.
    eexists l; unfold CallBagEnumerate, CallBagMethod; simpl; simplify with monad laws.
    computes_to_econstructor;  computes_to_inv; subst; eauto.
  Qed.

  Lemma realizeable_Find
  : forall
      (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
      (r_o : UnConstrQueryStructure qs_schema)
      idx st,
      DelegateToBag_AbsR r_o r_n ->
      exists v : list RawTuple,
        refine (l <- CallBagFind idx r_n st;
                ret (snd l))
               (ret v).
  Proof.
    intros; destruct (H idx) as [l [l_eqv l_eqv'] ].
    eexists (filter _ l).
      setoid_rewrite (refine_filter_BagFind H).
      simplify with monad laws.
      repeat computes_to_econstructor; eauto.
      intro; finish honing.
  Qed.

  Corollary refine_Join_Comp_Lists_filter_search_term_snd_dep'
            (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           (_ : DelegateToBag_AbsR r_o r_n)
           idx idx'
           (search_pattern : _ -> _)
           (resultComp : ilist2 (B:= @RawTuple) [_; _] -> Comp (list ResultT))
           filter_rest,
      refine (cl <- CallBagEnumerate idx r_n ;
              l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd cl))
                                     (fun _ => l <- CallBagEnumerate idx' r_n ;
                                      ret (snd l)));
              List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) [_ ; _] => BagMatchSearchTerm _ (search_pattern (ilist2_tl a)) (ilist2_hd a) && filter_rest a) l')
                            resultComp)
             (cl <- CallBagEnumerate idx r_n ;
              l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd cl))
                                     (fun tup => l <- CallBagFind idx' r_n (search_pattern tup);
                                      ret (snd l)));
              List_Query_In (filter filter_rest l') resultComp).
  Proof.
    intros; apply refine_bind;
    [reflexivity
    | intro;
      eapply refine_Join_Comp_Lists_filter_search_term_snd_dep; eauto].
  Qed.

  Lemma refine_Join_Comp_Lists_filter_search_term_fst
        (ResultT : Type) :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           (_ : DelegateToBag_AbsR r_o r_n)
           idx
           heading
           cl
           (search_pattern : _)
           (resultComp : ilist2 (B:= @RawTuple) [heading ; _] -> Comp (list ResultT))
           (cl_realizable : forall a, exists v, computes_to (cl a) v)
           filter_rest,
      refine (l <- CallBagEnumerate idx r_n ;
              l' <- Join_Comp_Lists (Build_single_Tuple_list (snd l)) cl;
              List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) [_ ; _] => (BagMatchSearchTerm _ search_pattern (ilist2_hd (ilist2_tl a)) && filter_rest a)) l')
                            resultComp)
             (l <- CallBagFind idx r_n search_pattern;
              l' <- Join_Comp_Lists (Build_single_Tuple_list (snd l)) cl;
              List_Query_In (filter filter_rest l') resultComp).
  Proof.
    intros.
    setoid_rewrite <- (@refine_BagFind_filter _ _ H idx (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern) search_pattern).
    intros; unfold CallBagFind, CallBagEnumerate, CallBagMethod; simpl.
    repeat setoid_rewrite (refineEquiv_bind_bind);
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
    f_equiv; unfold pointwise_relation; intros.
    let H := match goal with
                 |- refine (l' <- Join_Comp_Lists ?l ?c; (@?f l')) _ =>
                 constr:(fun B C => Join_Comp_Lists_apply_f (B := B) (C := C) l c)
             end in
    setoid_rewrite H with (c' := fun l => List_Query_In l _).
    setoid_rewrite <- refineEquiv_unit_bind.
    setoid_rewrite (filter_and_join_ilist_tail
               (fun a0 : ilist2 (B:= @RawTuple) [_] =>_ (ilist2_hd a0))
               (Build_single_Tuple_list a)); eauto.
    simplify with monad laws; f_equiv.
    unfold Build_single_Tuple_list; simpl;
    repeat rewrite ListFacts.filter_map; f_equiv.
    setoid_rewrite refineEquiv_bind_bind; setoid_rewrite refineEquiv_unit_bind;
    reflexivity.
    intro; reflexivity.
  Qed.

  Lemma refineEquiv_Join_Comp_Lists_Build_single_Tuple_list
  : forall (r_n : IndexedQueryStructure qs_schema BagIndexKeys) idx,
      refineEquiv (Join_Comp_Lists [inil2 (B := @RawTuple)]
                                   (fun _ : ilist2 (B:= @RawTuple) [] =>
                                      l <- CallBagEnumerate idx r_n ;
                                    ret (snd l)))
                  (l <- CallBagEnumerate idx r_n ;
                   ret (Build_single_Tuple_list (snd l))) .
  Proof.
    unfold Join_Comp_Lists, Build_single_Tuple_list; simpl; intros;
    repeat setoid_rewrite refineEquiv_bind_bind;
    repeat setoid_rewrite refineEquiv_bind_unit; f_equiv.
    intros u.
    rewrite app_nil_r; reflexivity.
  Qed.

  Lemma refine_BagADT_QSDelete_fst :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall (idx :Fin.t _)
                (DT : Ensemble RawTuple)
                (DT_Dec : DecideableEnsemble DT)
                search_pattern,
           ExtensionalEq (@DecideableEnsembles.dec _ _ DT_Dec)
                         (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)
           -> refine {x : list RawTuple |
                      QSDeletedTuples r_o idx DT x}
                     (l <- (CallBagDelete idx r_n search_pattern);
                      ret (snd l)).
  Proof.
    intros; setoid_rewrite DeletedTuplesFor; auto.
    rewrite refine_Query_In_Enumerate by eauto.
    setoid_rewrite refine_List_Query_In_Where.
    instantiate (1 := _).
    simpl in *.
    rewrite (refineEquiv_Join_Comp_Lists_Build_single_Tuple_list r_n idx).
    setoid_rewrite refineEquiv_bind_bind at 1.
    setoid_rewrite refineEquiv_bind_bind at 1.
    setoid_rewrite refineEquiv_bind_unit at 1.
    setoid_rewrite <- refineEquiv_bind_bind at 1.
    rewrite (refine_Query_For_In_Find_snd' H _ H0).
    setoid_rewrite refine_List_Query_In_Return.
    setoid_rewrite refine_filter_BagFind; eauto; simplify with monad laws.
    unfold Build_single_Tuple_list; setoid_rewrite map_map; simpl.
    setoid_rewrite map_id.
    unfold CallBagFind, CallBagDelete, CallBagMethod;
      simpl; try simplify with monad laws;
      repeat setoid_rewrite refineEquiv_bind_bind;
      repeat setoid_rewrite refineEquiv_bind_unit; simpl;
      f_equiv; intro.
    refine pick val _; eauto.
    erewrite filter_by_equiv; eauto.
    reflexivity.
  Qed.

  Lemma refine_BagADT_QSDelete_snd :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall (idx :Fin.t _)
                (DT : Ensemble RawTuple)
                (DT_Dec : DecideableEnsemble DT)
                search_pattern,
           ExtensionalEq (@DecideableEnsembles.dec _ _ DT_Dec)
                         (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)
           -> refine
                {r_n' |
                 DelegateToBag_AbsR
                   (UpdateUnConstrRelation r_o idx (EnsembleDelete
                                                      (GetUnConstrRelation r_o idx)
                                                      DT)) r_n'}
                (l <- (CallBagDelete idx r_n search_pattern);
                 ret (fst l)).
  Proof.
    intros.
    computes_to_constructor;  computes_to_inv.
    unfold CallBagDelete, CallBagMethod in *; simpl in *;  computes_to_inv; subst.
    simpl.
    unfold DelegateToBag_AbsR; intros.
    - destruct (fin_eq_dec idx idx0); subst.
      + rewrite get_update_unconstr_eq, get_update_indexed_eq.
        unfold DelegateToBag_AbsR in H.
        destruct (H idx0) as
            [l [ [ [bnd fresh_bnd] [l' [l'_eq [l_eqv NoDup_l'] ] ] ]
                  [ [bnd' fresh_bnd'] [l'' [l''_eq [l''_eqv NoDup_l''] ] ] ] ] ].
        exists (filter (fun a => negb (DecideableEnsembles.dec a)) l); repeat split.
        * exists bnd; unfold EnsembleDelete, UnConstrFreshIdx; intros.
          inversion H2; subst; eauto.
        * unfold UnIndexedEnsembleListEquivalence;
          exists (filter (fun a => negb (DecideableEnsembles.dec (indexedElement a))) l'); split; eauto.
          rewrite <- l'_eq; rewrite ListFacts.filter_map; reflexivity.
          intuition.
          apply filter_In; split.
          eapply l_eqv; inversion H2; eauto.
          inversion H2; subst; rewrite (proj2 (Decides_false _ _)); eauto.
          rewrite filter_In in H2; intuition; constructor;
          [ apply l_eqv; eauto
          | case_eq (DecideableEnsembles.dec (indexedElement x)); intros H'; rewrite H' in H4;
            try discriminate;
            eapply Decides_false in H'; eauto ].
          eapply NoDup_filter_map with (f := fun a => negb (DecideableEnsembles.dec a)); eauto.
        * exists bnd'; unfold EnsembleDelete, UnConstrFreshIdx; intros.
          inversion H2; subst; eauto.
        * unfold UnIndexedEnsembleListEquivalence;
          exists (filter (fun a => negb (DecideableEnsembles.dec (indexedElement a))) l''); split; eauto.
          rewrite <- l''_eq; rewrite ListFacts.filter_map; reflexivity.
          intuition.
          apply filter_In; split.
          eapply l''_eqv; inversion H2; eauto.
          inversion H2; subst; rewrite (proj2 (Decides_false _ _)); eauto.
          unfold Complement, Ensembles.In in *.
          intro; apply H4.
          rewrite <- H0.
          apply dec_decides_P; eauto.
          rewrite filter_In in H2; intuition; constructor;
          [ apply l''_eqv; eauto
          | case_eq (DecideableEnsembles.dec (indexedElement x)); intros H'; rewrite H' in H4;
            try discriminate;
            eapply Decides_false in H'; eauto ].
          unfold Complement, Ensembles.In; rewrite <- H0;
          eapply Decides_false in H'; rewrite H'; congruence.
          eapply NoDup_filter_map with (f := fun a => negb (DecideableEnsembles.dec a)); eauto.
      + rewrite get_update_unconstr_neq, get_update_indexed_neq; eauto.
  Qed.

  Lemma refine_Pick_DelegateToBag_AbsR
    : forall r_o r_n,
      DelegateToBag_AbsR r_o r_n
      -> refine {r_n : IndexedQueryStructure qs_schema BagIndexKeys |
                 DelegateToBag_AbsR r_o r_n}
                (ret r_n).
  Proof.
    intros; refine pick val r_n; eauto; reflexivity.
  Qed.

  Lemma refine_BagADT_QSInsert :
    forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n
      -> forall (idx :Fin.t _)
                t freshIdx,
        UnConstrFreshIdx (GetUnConstrRelation r_o idx) freshIdx
        -> refine
             {r_n' |
               DelegateToBag_AbsR
                 (UpdateUnConstrRelation r_o idx (
                                           EnsembleInsert
                                             {| indexedElement := t; elementIndex := freshIdx |}
                                             (GetUnConstrRelation r_o idx))) r_n'}
             (CallBagInsert idx r_n t).
  Proof.
    unfold refine; intros.
    unfold CallBagInsert, CallBagMethod in *; simpl in *; computes_to_inv; subst.
    computes_to_econstructor; simpl.
    unfold DelegateToBag_AbsR in *; intuition; intros.
    intros; destruct (fin_eq_dec idx idx0); subst.
    - rewrite get_update_unconstr_eq, get_update_indexed_eq.
      destruct (H idx0) as
          [l [ [ [bnd fresh_bnd] [l' [l'_eq [l_eqv NoDup_l'] ] ] ]
                [ [bnd' fresh_bnd'] [l'' [l''_eq [l''_eqv NoDup_l''] ] ] ] ] ].
      exists (cons t l); repeat split.
      + exists (S freshIdx); unfold EnsembleInsert, UnConstrFreshIdx; intros.
        unfold UnConstrFreshIdx in H0; intuition; subst; simpl; eauto.
      + unfold UnIndexedEnsembleListEquivalence;
                 exists ({| indexedElement := t; elementIndex := freshIdx |} :: l')%list; intuition.
        * simpl in *; rewrite l'_eq; trivial.
        * simpl; destruct H2;
          [left; symmetry; exact H2
           | right; apply l_eqv; eauto].
        * unfold EnsembleInsert; destruct H2;
          [rewrite <- H2; left; trivial
           | right; eapply l_eqv; eauto ].
        * simpl; apply NoDup_cons; eauto.
          unfold not; intros;
          apply in_map_iff in H2; destruct H2; destruct H2;
            apply l_eqv in H3. unfold UnConstrFreshIdx in H0;
            unfold In in H2; apply H0 in H3;
            unfold GetNRelSchema in *; omega.
      + exists (S v1); unfold Ensembles.Add, UnConstrFreshIdx; intros.
        inversion H2; subst.
        unfold UnConstrFreshIdx in H1; intuition; subst; simpl; eauto.
        inversion H3; subst.
        simpl; eauto.
      + unfold UnIndexedEnsembleListEquivalence;
                 exists ({| indexedElement := t; elementIndex := v1 |} :: l'')%list; intuition.
        * simpl in *; rewrite l''_eq; trivial.
        * simpl; destruct H2;
          [right; apply l''_eqv; eauto |
           left; inversion H2; reflexivity ].
        * unfold Ensembles.Add; destruct H2;
          [ right; subst; econstructor
          | left; eapply l''_eqv; eauto ].
        * simpl; apply NoDup_cons; eauto.
          unfold not; intros;
          apply in_map_iff in H2; destruct H2; destruct H2;
            apply l''_eqv in H3; unfold UnConstrFreshIdx in H1;
            unfold In in H2; apply H1 in H3;
            unfold GetNRelSchema in *; omega.
      - rewrite get_update_unconstr_neq, get_update_indexed_neq; eauto.
  Qed.

Lemma refine_BagADT_QSInsert' {ResultT}
     : forall
         (r_o : UnConstrQueryStructure qs_schema)
         (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
         (k  : _ -> Comp ResultT) (k' : _ -> Comp ResultT),
       DelegateToBag_AbsR r_o r_n ->
       forall (idx : Fin.t (numRawQSschemaSchemas qs_schema))
              (t : RawTuple) (freshIdx : nat),

         UnConstrFreshIdx (GetUnConstrRelation r_o idx) freshIdx ->
         (forall r_o r_n,
             DelegateToBag_AbsR r_o r_n ->
             refine (k r_o) (k' r_n))
         ->  refine
               (r_o' <- UpdateUnConstrRelationInsertC r_o idx {| elementIndex := freshIdx; indexedElement := t |};
                k r_o')
               (r_n' <- CallBagInsert idx r_n t;
                k' r_n').
Proof.
  unfold refine; intros.
  unfold CallBagInsert, CallBagMethod in *; simpl in *; computes_to_inv; subst.
    computes_to_econstructor; simpl.
    unfold UpdateUnConstrRelationInsertC; computes_to_econstructor.
    eapply H1; eauto.
    unfold DelegateToBag_AbsR in *; intuition; intros.
    intros; destruct (fin_eq_dec idx idx0); subst.
    - rewrite get_update_unconstr_eq, get_update_indexed_eq.
      destruct (H idx0) as
          [l [ [ [bnd fresh_bnd] [l' [l'_eq [l_eqv NoDup_l'] ] ] ]
                [ [bnd' fresh_bnd'] [l'' [l''_eq [l''_eqv NoDup_l''] ] ] ] ] ].
      exists (cons t l); repeat split.
      + exists (S freshIdx); unfold EnsembleInsert, UnConstrFreshIdx; intros.
        unfold UnConstrFreshIdx in H0; intuition; subst; simpl; eauto.
      + unfold UnIndexedEnsembleListEquivalence;
                 exists ({| indexedElement := t; elementIndex := freshIdx |} :: l')%list; intuition.
        * simpl in *; rewrite l'_eq; trivial.
        * simpl; destruct H3;
          [left; symmetry; exact H3
           | right; apply l_eqv; eauto].
        * unfold EnsembleInsert; destruct H3;
          [rewrite <- H3; left; trivial
           | right; eapply l_eqv; eauto ].
        * simpl; apply NoDup_cons; eauto.
          unfold not; intros;
          apply in_map_iff in H3; destruct H3; destruct H3;
            apply l_eqv in H4. unfold UnConstrFreshIdx in H0;
            unfold In in H3; apply H0 in H4;
            unfold GetNRelSchema in *; omega.
      + exists (S v2); unfold Ensembles.Add, UnConstrFreshIdx; intros.
        inversion H3; subst.
        unfold UnConstrFreshIdx in H2; intuition; subst; simpl; eauto.
        inversion H4; subst.
        simpl; eauto.
      + unfold UnIndexedEnsembleListEquivalence;
                 exists ({| indexedElement := t; elementIndex := v2 |} :: l'')%list; intuition.
        * simpl in *; rewrite l''_eq; trivial.
        * simpl; destruct H3;
          [right; apply l''_eqv; eauto |
           left; inversion H3; reflexivity ].
        * unfold Ensembles.Add; destruct H3;
          [ right; subst; econstructor
          | left; eapply l''_eqv; eauto ].
        * simpl; apply NoDup_cons; eauto.
          unfold not; intros;
          apply in_map_iff in H3; destruct H3; destruct H3;
            apply l''_eqv in H4; unfold UnConstrFreshIdx in H2;
            unfold In in H3; apply H2 in H4;
            unfold GetNRelSchema in *; omega.
      - rewrite get_update_unconstr_neq, get_update_indexed_neq; eauto.
  Qed.

Lemma refine_BagADT_QSDelete' {ResultT}
  : forall
    (r_o : UnConstrQueryStructure qs_schema)
    (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
    idx
    DeletedTuples
    (k  : _ -> Comp ResultT) (k' : _ -> Comp ResultT)
    (DT_Dec : DecideableEnsemble DeletedTuples)
    search_pattern,
    ExtensionalEq (@DecideableEnsembles.dec _ _ DT_Dec)
                  (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_pattern)
    -> DelegateToBag_AbsR r_o r_n
    -> (forall r_o r_n,
           DelegateToBag_AbsR r_o r_n ->
           refine (k r_o) (k' r_n))
    ->  refine
          (r_o' <- UpdateUnConstrRelationDeleteC r_o idx DeletedTuples;
           k r_o')
          (r_n' <- CallBagDelete idx r_n search_pattern;
           k' (fst r_n')).
Proof.
  unfold refine; intros.
  unfold CallBagDelete, CallBagMethod in H2; simpl in H2;
    computes_to_inv; subst; simpl in *.
  unfold UpdateUnConstrRelationDeleteC; repeat computes_to_econstructor.
  eapply H1; eauto.
  unfold DelegateToBag_AbsR; intros.
  intros; destruct (fin_eq_dec idx idx0); subst.
  - rewrite get_update_unconstr_eq, get_update_indexed_eq.
    destruct (H0 idx0) as
        [l [ [ [bnd fresh_bnd] ? ]
               [ [bnd' fresh_bnd'] ? ] ] ].
    pose proof (UnIndexedEnsembleListEquivalence_Delete DT_Dec H3).
    pose proof (UnIndexedEnsembleListEquivalence_Delete DT_Dec H4).
    eexists (filter (fun a : RawTuple => negb (DecideableEnsembles.dec a)) l); split;
      unfold EnsembleIndexedListEquivalence; split; eauto;
        try solve [eexists _; eauto using UnConstrFreshIdx_Delete].
    eapply UnIndexedEnsembleListEquivalence_Same_set; eauto.
    split; unfold Included; intros; inversion H7; subst;
      econstructor; eauto;
        unfold Complement, Ensembles.In in *.
    + eapply Decides_false in H9; rewrite H in H9. congruence.
    + eapply Decides_false; rewrite <- H in H9; destruct (DecideableEnsembles.dec (indexedElement x));
        congruence.
  - rewrite get_update_unconstr_neq, get_update_indexed_neq; eauto.
Qed.

Corollary refine_Join_Comp_Lists_filter_filter_search_term_snd_dep'
          (ResultT : Type) :
  forall r_o (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           (_ : DelegateToBag_AbsR r_o r_n)
         idx idx'
         (search_pattern : _ -> _)
         (resultComp : ilist2 (B:= @RawTuple) [_; _] -> Comp (list ResultT))
         filter_rest st,
    refine (cl <- CallBagFind idx r_n st;
            l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd cl))
                                   (fun _ => l <- CallBagEnumerate idx' r_n ;
                                    ret (snd l)));
            List_Query_In (filter (fun a : ilist2 (B:= @RawTuple) [_ ; _] => BagMatchSearchTerm _ (search_pattern (ilist2_tl a)) (ilist2_hd a) && filter_rest a) l')
                          resultComp)
           (cl <- CallBagFind idx r_n st;
            l' <- (Join_Comp_Lists (Build_single_Tuple_list (snd cl))
                                   (fun tup => l <- CallBagFind idx' r_n (search_pattern tup);
                                    ret (snd l)));
            List_Query_In (filter filter_rest l') resultComp).
Proof.
  intros; f_equiv; intro;
  eapply refine_Join_Comp_Lists_filter_search_term_snd_dep; eauto.
Qed.

End BagsQueryStructureRefinements.

Lemma CallBagFind_fst
      {qs_schema : RawQueryStructureSchema}
      {BagIndexKeys : ilist3 (qschemaSchemas qs_schema)}
  : forall (idx : Fin.t (numRawQSschemaSchemas qs_schema))
           (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           (st : BagSearchTermType (ith3 BagIndexKeys idx))
           a,
    CallBagMethod idx BagFind r_n st ↝ a
    -> r_n = (UpdateIndexedRelation _ _ r_n idx (fst a)).
Proof.
  unfold CallBagMethod; intros.
  simpl in *; computes_to_inv; subst.
  simpl.
  unfold UpdateIndexedRelation.
  unfold GetIndexedRelation.
  unfold IndexedQueryStructure in r_n.
  eapply ilist3_eq_ith3; intros.
  destruct (fin_eq_dec idx idx0); subst.
  rewrite i3th_replace_Index_eq; reflexivity.
  rewrite i3th_replace_Index_neq; eauto.
Qed.

Lemma CallBagEnumerate_fst
      {qs_schema : RawQueryStructureSchema}
      {BagIndexKeys : ilist3 (qschemaSchemas qs_schema)}
  : forall (idx : Fin.t (numRawQSschemaSchemas qs_schema))
           (r_n : IndexedQueryStructure qs_schema BagIndexKeys)
           a,
    CallBagMethod idx BagEnumerate r_n ↝ a
    -> r_n = (UpdateIndexedRelation _ _ r_n idx (fst a)).
Proof.
  unfold CallBagMethod; intros.
  simpl in *; computes_to_inv; subst.
  simpl.
  unfold UpdateIndexedRelation.
  unfold GetIndexedRelation.
  unfold IndexedQueryStructure in r_n.
  eapply ilist3_eq_ith3; intros.
  destruct (fin_eq_dec idx idx0); subst.
  rewrite i3th_replace_Index_eq; reflexivity.
  rewrite i3th_replace_Index_neq; eauto.
Qed.

Lemma List_Query_In_Return' :
  forall (n : nat) (ResultT : Type) (headings : Vector.t RawHeading n) (f f' : _ -> Comp (list ResultT))
         (l : list (ilist2 (B := @RawTuple) headings)),
    (forall tup, refine (f tup) (f' tup))
    -> refine (List_Query_In l f)
              (List_Query_In l f').
Proof.
  unfold List_Query_In.
  intros; eapply refine_flatten_CompList_func; eauto.
Qed.

Definition CallBagCount {qs_schema BagIndexKeys}
           idx (r_n : IndexedQueryStructure qs_schema BagIndexKeys) st :=
  br <- CallBagMethod idx BagCount r_n st;
    ret (UpdateIndexedRelation qs_schema _ r_n idx (fst br), snd br).

Lemma refine_BagFindBag_single {ResultT} :
  forall qs_schema BagIndexKeys idx r_o r_n search_term P
         (f : _ -> ResultT)
         (P_dec : DecideableEnsemble P),
    @DelegateToBag_AbsR qs_schema BagIndexKeys r_o r_n
    -> ExtensionalEq DecideableEnsembles.dec (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_term)
    -> refine (For (UnConstrQuery_In r_o idx
                                     (fun tup => Where (P tup) Return (f tup))))
              (r_n' <- CallBagFind qs_schema BagIndexKeys idx r_n search_term;
                 ret (map f (snd r_n'))).
Proof.
    intros.
  rewrite refine_For.
  etransitivity.
  apply refine_under_bind_both.
  etransitivity.
  apply refine_Filtered_Query_In_Enumerate; eauto.
  apply refine_under_bind; intros.
  match goal with
  | [H : @DelegateToBag_AbsR ?qs_schema ?indexes ?r_o ?r_n
     |- refine (List_Query_In ?b (fun b' : ?QueryT => Where (@?P b') (@?resultComp b'))) _ ] =>
    etransitivity;
      [ let H' := eval simpl in (@refine_List_Query_In_Where QueryT _ b P resultComp) in
            pose proof H'
      | ]
  end.
  eapply (H2 {| DecideableEnsembles.dec := fun tup => DecideableEnsembles.dec (prim_fst tup) |}).
  simpl.
  finish honing.
  intros; finish honing.
  simpl.
  etransitivity.
  apply refine_under_bind_both.
  apply (fun heading => @refine_Join_Filtered_Comp_Lists_filter_tail _ heading [ ]%vector); intros.
  intros; finish honing.
  simpl.
  setoid_rewrite Join_Filtered_Comp_Lists_ExtensionalEq_filters;
    [ | unfold ExtensionalEq in *; intros [? ?]; simpl; rewrite H0;
        instantiate (1 := fun tup => BagMatchSearchTerm (ith3 BagIndexKeys idx) search_term (ilist2_hd tup) && true); simpl; rewrite andb_true_r; eauto ].
  rewrite (@refine_Join_Comp_Lists_To_Find _ _ 0 _ _ H [ ]%vector).
  simplify with monad laws.
  unfold Join_Comp_Lists; simpl.
  unfold CallBagFind, CallBagCount; autorewrite with monad laws.
  f_equiv; intro.
  simpl.
  rewrite app_nil_r.
  rewrite (List_Query_In_Return _
                                (map (fun fa : RawTuple => icons2 fa inil2) a)
                                (fun tup => f (prim_fst tup))).
  simplify with monad laws.
  refine pick val _.
  reflexivity.
  simpl.
  rewrite Permutation_map.
  2: reflexivity.
  rewrite map_map; simpl.
  induction a; simpl; eauto.
  Unshelve.
  simpl.
  intro; rewrite dec_decides_P; reflexivity.
Qed.

Lemma refine_BagFindBagCount {ResultT} :
  forall qs_schema BagIndexKeys idx r_o r_n search_term P
         (f : _ -> ResultT)
         (P_dec : DecideableEnsemble P),
    @DelegateToBag_AbsR qs_schema BagIndexKeys r_o r_n
    -> ExtensionalEq DecideableEnsembles.dec (BagMatchSearchTerm (ith3 BagIndexKeys idx) search_term)
    -> refine (Count For (UnConstrQuery_In r_o idx
                                           (fun tup => Where (P tup) Return (f tup))))
              (r_n' <- CallBagCount idx r_n search_term;
                 ret (snd r_n')).
Proof.
  intros.
  rewrite refine_Count, refine_BagFindBag_single; eauto.
  rewrite !refine_bind_bind.
  unfold CallBagFind, CallBagCount; autorewrite with monad laws.
  f_equiv; intro.
  simpl.
  rewrite !map_length; reflexivity.
Qed.

Lemma exists_UnConstrFreshIdx_Max :
    forall (qs_schema : RawQueryStructureSchema) (BagIndexKeys : ilist3 (qschemaSchemas qs_schema))
           (r_o : UnConstrQueryStructure qs_schema) (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
      DelegateToBag_AbsR r_o r_n ->
      exists bnd : nat,
      forall idx : Fin.t (numRawQSschemaSchemas qs_schema), UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd.
  Proof.
    unfold DelegateToBag_AbsR; intros.
    assert (forall idx : Fin.t (numRawQSschemaSchemas qs_schema),
               exists l : list RawTuple,
                 EnsembleIndexedListEquivalence (GetUnConstrRelation r_o idx) l) by
        (intros; destruct (H idx) as [ ? [? ?] ]; eauto).
    destruct qs_schema; simpl in *;
      revert H0 ; generalize (GetUnConstrRelation r_o); clear.
    simpl; clear.
    induction qschemaSchemas; simpl; intros.
    - exists 0; intro; inversion idx.
    - destruct (IHqschemaSchemas (fun idx => i (Fin.FS idx))
                                 (fun idx => H0 (Fin.FS idx))).
      destruct (H0 Fin.F1) as [l [ [bound' ?] ?] ].
      exists (max bound' x); intros.
      generalize qschemaSchemas i H1 H; clear; pattern n, idx.
      apply Fin.caseS; intros;  unfold UnConstrFreshIdx in *; intros.
      apply H1 in H0; destruct (Max.max_spec bound' x); intuition.
      apply H in H0; destruct (Max.max_spec bound' x); intuition.
      rewrite H4; eauto.
      rewrite H4.
      eapply lt_le_trans; eauto.
  Qed.

Arguments CallBagMethod : simpl never.
Arguments CallBagMethod [_ _] _ _ _.

Arguments CallBagConstructor : simpl never.
Arguments GetIndexedRelation [_ _ ] _ _ _.
Arguments DelegateToBag_AbsR [_ _] _ _.

Arguments CallBagFind : simpl never.
Arguments CallBagFind [_ _] _ _ _ _.

Arguments CallBagCount : simpl never.
Arguments CallBagCount [_ _] _ _ _ _.

Arguments CallBagInsert : simpl never.
Arguments CallBagInsert [_ _] _ _ _ _.

Arguments CallBagDelete : simpl never.
Arguments CallBagDelete [_ _] _ _ _ _.

Arguments CallBagEnumerate : simpl never.
Arguments CallBagEnumerate [_ _] _ _ _.


(*
 * © 2019 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Morphisms
     Eqdep
.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     MessageEq
     Keys
     AdversaryUniverse
.

From SPICY Require
     IdealWorld
     RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       .

Set Implicit Arguments.

Section IdealDefiniions.

  Import IdealWorld.

  Definition istepSilent {A} (U1 U2 : universe A) :=
    lstep_universe U1 Silent U2.

  Inductive indexedIdealStep {A} (uid : user_id) (lbl : label) (U1 U2 : universe A) : Prop :=
  | IndexedIdealStep : forall u proto chans prms,
      U1.(users) $? uid = Some u
      -> lstep_user uid lbl (U1.(channel_vector), u.(protocol), u.(perms)) (chans, proto, prms)
      -> U2 = construct_universe
               chans
               (U1.(users) $+ (uid, {| protocol := proto ; perms := prms |}))
      -> indexedIdealStep uid lbl U1 U2.

  Lemma indexedIdealStep_ideal_step :
    forall A uid lbl U1 U2,
      @indexedIdealStep A uid lbl U1 U2
      -> lstep_universe U1 lbl U2.
  Proof. intros * IND; invert IND; econstructor; eauto. Qed.

End IdealDefiniions.

Section RealDefinitions.
  Import RealWorld.

  Inductive indexedRealStep {A B} (uid : user_id) (lbl : label) (U1 U2 : universe A B) : Prop :=
  | IndexedRealStep : forall userData usrs adv cs gks ks qmsgs mycs froms sents cur_n (cmd : user_cmd (Base A)),
      U1.(users) $? uid = Some userData
      -> step_user lbl (Some uid)
                  (build_data_step U1 userData)
                  (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> U2 = buildUniverse usrs adv cs gks uid {| key_heap  := ks
                                                   ; msg_heap  := qmsgs
                                                   ; protocol  := cmd
                                                   ; c_heap    := mycs
                                                   ; from_nons := froms
                                                   ; sent_nons := sents
                                                   ; cur_nonce := cur_n |}
      -> indexedRealStep uid lbl U1 U2.

  Lemma indexedRealStep_real_step :
    forall A B uid lbl U1 U2,
      @indexedRealStep A B uid lbl U1 U2
      -> step_universe (Some uid) U1 (mkULbl lbl uid) U2.
  Proof. intros * IND; invert IND; econstructor; eauto. Qed.

End RealDefinitions.

Inductive chan_key : Set :=
| Public (ch_id : IdealWorld.channel_id)
| Auth (ch_id : IdealWorld.channel_id): forall k,
    k.(keyUsage) = Signing -> chan_key
| Enc  (ch_id : IdealWorld.channel_id) : forall k,
    k.(keyUsage) = Encryption -> chan_key
| AuthEnc (ch_id : IdealWorld.channel_id) : forall k1 k2,
      k1.(keyUsage) = Signing
    -> k2.(keyUsage) = Encryption
    -> chan_key
.

Inductive action_matches (cs : RealWorld.ciphers) (gks : keys) :
  RealWorld.uaction -> IdealWorld.action -> Prop :=

| InpSig : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid uid seq froms p cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigCipher kid uid seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (uid, RealWorld.Input m__rw p froms) (IdealWorld.Input m__iw uid ch_id chans ps)
| InpEnc : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid1 kid2 uid seq froms p cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigEncCipher kid1 kid2 uid seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (uid, RealWorld.Input m__rw p froms) (IdealWorld.Input m__iw uid ch_id chans ps)
| OutSig : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid seq to from sents cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigCipher kid to seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (from, RealWorld.Output m__rw (Some from) (Some to) sents) (IdealWorld.Output m__iw from ch_id chans ps)
| OutEnc : forall t (m__rw : RealWorld.crypto t) (msg__rw : RealWorld.message.message t) (m__iw : IdealWorld.message.message t)
          kid1 kid2 seq to from sents cid ch_id chans ps,
    m__rw = RealWorld.SignedCiphertext cid
    -> cs $? cid = Some (RealWorld.SigEncCipher kid1 kid2 to seq msg__rw)
    -> content_eq msg__rw m__iw gks
    -> action_matches cs gks (from, RealWorld.Output m__rw (Some from) (Some to) sents) (IdealWorld.Output m__iw from ch_id chans ps)
.

Section RealWorldUniverseProperties.
  Import RealWorld.

  Variable honestk : key_perms.

  Definition permission_heap_honest (perms : key_perms) :=
    forall k_id p,
     perms $? k_id = Some p
      -> honestk $? k_id = Some true.

  Definition permission_heap_good (ks : keys) (perms : key_perms) :=
    forall k_id p,
      perms $? k_id = Some p
      -> exists k, ks $? k_id = Some k.

  (* Syntactic Predicates *)
  Definition keys_and_permissions_good {A} (ks : keys) (usrs : honest_users A) (adv_heap : key_perms): Prop :=
    (forall k_id k,
          ks $? k_id = Some k
        -> keyId k = k_id)
    /\ Forall_natmap (fun u => permission_heap_good ks u.(key_heap)) usrs
    /\ permission_heap_good ks adv_heap.

  Definition user_cipher_queue_ok (cs : ciphers) (honestk : key_perms) :=
    Forall (fun cid => exists c, cs $? cid = Some c
                       /\ cipher_honestly_signed honestk c = true).

  Definition user_cipher_queues_ok {A} (cs : ciphers) (honestk : key_perms) (usrs : honest_users A) :=
    Forall_natmap
      (fun u => user_cipher_queue_ok cs honestk u.(c_heap)) usrs.

  Definition adv_cipher_queue_ok {A} (cs : ciphers) (usrs : honest_users A) :=
    Forall (fun cid => exists new_cipher,
                cs $? cid = Some new_cipher
                /\ ( cipher_honestly_signed (findUserKeys usrs) new_cipher = false
                  \/ ( cipher_honestly_signed (findUserKeys usrs) new_cipher = true
                    /\ exists u_id u rec_u,
                      fst (cipher_nonce new_cipher) = Some u_id
                      /\ usrs $? u_id = Some u
                      /\ u_id <> cipher_to_user new_cipher
                      /\ List.In (cipher_nonce new_cipher) u.(sent_nons)
                      /\ usrs $? cipher_to_user new_cipher = Some rec_u
                      /\ ( List.In (cipher_nonce new_cipher) rec_u.(from_nons)
                        \/ Exists (fun sigM => match sigM with
                                           | existT _ _ m =>
                                             msg_signed_addressed (findUserKeys usrs) cs (Some (cipher_to_user new_cipher)) m = true
                                           /\ msg_nonce_same new_cipher cs m
                                           end) rec_u.(msg_heap))))
           ).

  Inductive encrypted_cipher_ok (cs : ciphers) (gks : keys): cipher -> Prop :=
  | SigCipherHonestOk : forall {t} (msg : message t) msg_to nonce k kt,
      honestk $? k = Some true
      -> gks $? k = Some {| keyId := k; keyUsage := Signing; keyType := kt |}
      (* only send honest public keys *)
      -> (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true /\ kp = false)
      -> encrypted_cipher_ok cs gks (SigCipher k msg_to nonce msg)
  | SigCipherNotHonestOk : forall {t} (msg : message t) msg_to nonce k kt,
      honestk $? k <> Some true
      -> gks $? k = Some {| keyId := k; keyUsage := Signing; keyType := kt |}
      -> encrypted_cipher_ok cs gks (SigCipher k msg_to nonce msg)
  | SigEncCipherAdvSignedOk :  forall {t} (msg : message t) msg_to nonce k__s k__e kt__s kt__e,
      honestk $? k__s <> Some true
      -> gks $? k__s = Some {| keyId := k__s; keyUsage := Signing; keyType := kt__s |}
      -> gks $? k__e = Some {| keyId := k__e; keyUsage := Encryption; keyType := kt__e |}
      -> (forall k kp, findKeysMessage msg $? k = Some kp
                 -> exists v, gks $? k = Some v
                      /\ (kp = true -> honestk $? k <> Some true))
      -> encrypted_cipher_ok cs gks (SigEncCipher k__s k__e msg_to nonce msg)
  | SigEncCipherHonestSignedEncKeyHonestOk : forall {t} (msg : message t) msg_to nonce k__s k__e kt__s kt__e,
      honestk $? k__s = Some true
      -> honestk $? k__e = Some true
      -> gks $? k__s = Some {| keyId := k__s; keyUsage := Signing; keyType := kt__s |}
      -> gks $? k__e = Some {| keyId := k__e; keyUsage := Encryption; keyType := kt__e |}
      (* only send honest keys *)
      -> (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true)
      -> encrypted_cipher_ok cs gks (SigEncCipher k__s k__e msg_to nonce msg).

  Definition encrypted_ciphers_ok (cs : ciphers) (gks : keys) :=
    Forall_natmap (encrypted_cipher_ok cs gks) cs.

  Definition message_no_adv_private {t} (cs : ciphers) (msg : crypto t) :=
    forall k p, findKeysCrypto cs msg $? k = Some p -> honestk $? k = Some true /\ p = false.

  Definition adv_message_queue_ok {A} (usrs : honest_users A)
             (cs : ciphers) (gks : keys) (msgs : queued_messages) :=
    Forall (fun sigm => match sigm with
                     | (existT _ _ m) =>
                       (forall cid, msg_cipher_id m = Some cid -> cs $? cid <> None)
                     /\ (forall k kp,
                           findKeysCrypto cs m $? k = Some kp
                           -> gks $? k <> None /\ (kp = true -> (findUserKeys usrs) $? k <> Some true))
                     /\ (forall k,
                           msg_signing_key cs m = Some k
                           -> gks $? k <> None)
                     /\ (forall c_id, List.In c_id (findCiphers m)
                                -> exists c, cs $? c_id = Some c
                                     /\ ( cipher_honestly_signed (findUserKeys usrs) c = false
                                       \/ ( cipher_honestly_signed (findUserKeys usrs) c = true
                                         /\ exists uid u rec_u,
                                           fst (cipher_nonce c) = Some uid
                                           /\ usrs $? uid = Some u
                                           /\ uid <> cipher_to_user c
                                           /\ List.In (cipher_nonce c) u.(sent_nons)
                                           /\ usrs $? cipher_to_user c = Some rec_u
                                           /\ ( List.In (cipher_nonce c) rec_u.(from_nons)
                                             \/ Exists (fun sigM =>
                                                         match sigM with
                                                         | existT _ _ m =>
                                                           msg_signed_addressed (findUserKeys usrs) cs (Some (cipher_to_user c)) m = true
                                                           /\ msg_nonce_same c cs m
                                                         end) rec_u.(msg_heap)))))
                     end
           ) msgs.

  Definition message_queue_ok (cs : ciphers) (msgs : queued_messages) (gks : keys) :=
    Forall (fun sigm => match sigm with
                     | (existT _ _ m) =>
                       (forall k kp, findKeysCrypto cs m $? k = Some kp -> gks $? k <> None)
                     /\ (forall cid,
                           msg_cipher_id m = Some cid
                           -> cs $? cid <> None)
                     /\ (forall k,
                           msg_signing_key cs m = Some k
                           -> gks $? k <> None
                           /\ ( honest_key honestk k
                             -> message_no_adv_private cs m)
                       )
                     end) msgs.

  Definition adv_no_honest_keys (advk : key_perms) : Prop :=
    forall k_id,
      (  honestk $? k_id = None
      \/  honestk $? k_id = Some false
      \/ (honestk $? k_id = Some true /\ advk $? k_id <> Some true)
      ).

  Definition honest_users_only_honest_keys {A} (usrs : honest_users A) :=
    forall u_id u,
      usrs $? u_id = Some u
      -> forall k_id kp,
        u.(key_heap) $? k_id = Some kp
        -> findUserKeys usrs $? k_id = Some true.

  Definition honest_nonce_tracking_ok (cs : ciphers) (honestk : key_perms)
             (me : option user_id) (my_sents : sent_nonces) (my_cur_n : nat)
             (to_usr : user_id) (to_froms : recv_nonces) (to_msgs : queued_messages) :=

      (* Forall (fun non => snd non < my_cur_n) my_sents *)
      Forall (fun non => fst non = me -> snd non < my_cur_n) to_froms
    /\ Forall (fun '(existT _ _ msg) =>
                forall c_id c,
                  msg = SignedCiphertext c_id
                  -> cs $? c_id = Some c
                  -> honestk $? (cipher_signing_key c) = Some true
                  -> cipher_to_user c = to_usr
                  -> fst (cipher_nonce c) = me
                  -> snd (cipher_nonce c) < my_cur_n
             ) to_msgs
    /\ forall c_id c,
        cs $? c_id = Some c
      -> honestk $? (cipher_signing_key c) = Some true
      -> fst (cipher_nonce c) = me (* if cipher created by me *)
      (* -> snd (cipher_nonce c) < my_cur_n *)
      -> cipher_to_user c = to_usr
      -> ~ List.In (cipher_nonce c) my_sents (* and hasn't yet been sent *)
      -> ~ List.In (cipher_nonce c) to_froms (* then it hasn't been read by destination user *)
        /\ Forall (fun '(existT _ _ msg) => (* and isn't in destination user's message queue *)
                    msg_honestly_signed  honestk cs msg = true
                    -> msg_to_this_user cs (Some to_usr) msg = false
                      \/ msg_nonce_not_same c cs msg) to_msgs.

  Definition honest_user_nonces_ok (cs : ciphers) (honestk : key_perms)
             (me : option user_id) (my_sents : sent_nonces) (my_cur_n : nat) :=
    (forall c_id c,
      cs $? c_id = Some c
      -> honestk $? (cipher_signing_key c) = Some true
      -> fst (cipher_nonce c) = me (* if cipher created by me *)
      -> snd (cipher_nonce c) < my_cur_n)
  /\ Forall (fun non => snd non < my_cur_n) my_sents
  .

  Definition honest_nonces_unique (cs : ciphers) (honestk : key_perms) :=
    (forall cid1 cid2 c1 c2,
        cid1 <> cid2
        -> cs $? cid1 = Some c1
        -> cs $? cid2 = Some c2
        -> honestk $? (cipher_signing_key c1) = Some true
        -> honestk $? (cipher_signing_key c2) = Some true
        -> cipher_nonce c1 <> cipher_nonce c2).

  Definition action_adversary_safe (honestk : key_perms) (cs : ciphers) (a : action) : Prop :=
    match a with
    | Input  msg pat froms    => msg_pattern_safe honestk pat
                              /\ exists c_id c, msg = SignedCiphertext c_id
                                        /\ cs $? c_id = Some c
                                        /\ ~ List.In (cipher_nonce c) froms
    | Output msg msg_from msg_to sents => msg_honestly_signed honestk cs msg = true
                                       /\ msg_to_this_user cs msg_to msg = true
                                       /\ exists c_id c, msg = SignedCiphertext c_id
                                                 /\ cs $? c_id = Some c
                                                 /\ fst (cipher_nonce c) = msg_from  (* only send my messages *)
                                                 /\ ~ List.In (cipher_nonce c) sents
    end.

End RealWorldUniverseProperties.

Section SafeActions.
  Import RealWorld.

  Inductive nextAction : forall {A B}, user_cmd A -> user_cmd B -> Prop :=
  | NaReturn : forall A (a : << A >>),
      nextAction (Return a) (Return a)
  | NaGen :
      nextAction Gen Gen
  | NaSend : forall t uid (msg : crypto t),
      nextAction (Send uid msg) (Send uid msg)
  | NaRecv : forall t pat,
      nextAction (@Recv t pat) (@Recv t pat)
  | NaSignEncrypt : forall t k__s k__e u_id (msg : message t),
      nextAction (SignEncrypt k__s k__e u_id msg) (SignEncrypt k__s k__e u_id msg)
  | NaDecrypt : forall t (msg : crypto t),
      nextAction (Decrypt msg) (Decrypt msg)
  | NaSign : forall t k u_id (msg : message t),
      nextAction (Sign k u_id msg) (Sign k u_id msg)
  | NaVerify : forall t k (msg : crypto t),
      nextAction (Verify k msg) (Verify k msg)
  | NaGenKey : forall kt usg,
      nextAction (GenerateKey kt usg) (GenerateKey kt usg)
  | NaBind : forall A B r (c : user_cmd B) (c1 : user_cmd r) (c2 : << r >> -> user_cmd A),
      nextAction c1 c
      -> nextAction (Bind c1 c2) c
  .

  Lemma nextAction_couldBe :
    forall {A B} (c1 : user_cmd A) (c2 : user_cmd B),
      nextAction c1 c2
      -> match c2 with
        | Return _ => True
        | Gen => True
        | Send _ _ => True
        | Recv _ => True
        | SignEncrypt _ _ _ _ => True
        | Decrypt _ => True
        | Sign _ _ _ => True
        | Verify _ _ => True
        | GenerateKey _ _ => True
        (* | GenerateAsymKey _ => True *)
        (* | GenerateSymKey _ => True *)
        | Bind _ _ => False
        end.
  Proof.
    induction 1; eauto.
  Qed.

  Definition next_cmd_safe (honestk : key_perms) (cs : ciphers) (u_id : user_id)
             (froms : recv_nonces) (sents : sent_nonces) {A} (cmd : user_cmd A) :=
    forall B (cmd__n : user_cmd B),
      nextAction cmd cmd__n
      -> match cmd__n with
        | Return _ => True
        | Gen => True
        | Send msg_to msg =>
          msg_honestly_signed honestk cs msg = true
          /\ msg_to_this_user cs (Some msg_to) msg = true
          /\ (exists c_id c, msg = SignedCiphertext c_id
                       /\ cs $? c_id = Some c
                       /\ fst (cipher_nonce c) = (Some u_id)  (* only send my messages *)
                       /\ ~ List.In (cipher_nonce c) sents)
        | Recv pat =>
          msg_pattern_safe honestk pat
        | SignEncrypt k__sign k__enc msg_to msg =>
          honestk $? k__enc = Some true
          /\ (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true)
        | Decrypt _ => True
        | Sign _ _ msg =>
          (forall k_id kp, findKeysMessage msg $? k_id = Some kp -> honestk $? k_id = Some true /\ kp = false)
        | Verify _ _ => True
        | GenerateKey _ _ => True
        | Bind _ _ => False
        end.

  Definition honest_cmds_safe {A B} (U : universe A B) : Prop :=
    forall u_id u honestk,
      honestk = findUserKeys U.(users)
      -> U.(users) $? u_id = Some u
      (* -> forall lbl bd, step_user lbl (Some u_id) (build_data_step U u) bd *)
      -> next_cmd_safe (findUserKeys U.(users)) U.(all_ciphers) u_id u.(from_nons) u.(sent_nons) u.(protocol).

  Definition label_safe (honestk : key_perms) (cs : ciphers) (lbl : label) : Prop :=
    match lbl with
    | Silent   => True
    | Action a => action_adversary_safe honestk cs a
    end.

End SafeActions.

Section FinalValue.

    Inductive final_value : Set :=
    | FAccess
    | FBool (b : bool)
    | FNat (n : nat)
    | FUnit
    | FPair (fv1 fv2 : final_value).

    Section IdealFV.
      Import IdealWorld.
      Import IdealWorld.IdealNotations.

      Fixpoint Iret_val_to_val { t : type } :
        forall (rv : << Base t >>), final_value :=
        match t with
        | Nat => (fun n => FNat n)
        | Bool => (fun b => FBool b)
        | Unit => (fun _ => FUnit)
        | Access => (fun _ => FAccess)
        | TPair t1 t2 => (fun '(f, s) => FPair (Iret_val_to_val f) (Iret_val_to_val s))
        end.

    End IdealFV.

    Section RealFV.
      Import RealWorld.
      Import RealWorld.RealWorldNotations.

      Fixpoint Rret_val_to_val { t : type } :
        forall (rv : << Base t >>), final_value :=
        match t with
        | Nat => (fun n => FNat n)
        | Bool => (fun b => FBool b)
        | Unit => (fun _ => FUnit)
        | Access => (fun _ => FAccess)
        | TPair t1 t2 => (fun '(f, s) => FPair (Rret_val_to_val f) (Rret_val_to_val s))
        end.

    End RealFV.

End FinalValue.

Definition message_queues_ok {A} (cs : RealWorld.ciphers) (usrs : RealWorld.honest_users A) (gks : keys) :=
  Forall_natmap (fun u => message_queue_ok (RealWorld.findUserKeys usrs) cs u.(RealWorld.msg_heap) gks) usrs.

Definition honest_nonces_ok {A} (cs : RealWorld.ciphers) (usrs : RealWorld.honest_users A) :=
    honest_nonces_unique cs (RealWorld.findUserKeys usrs)
  /\ ( forall uid u,
        usrs $? uid = Some u
        -> honest_user_nonces_ok cs (RealWorld.findUserKeys usrs) (Some uid)
                                u.(RealWorld.sent_nons)
                                u.(RealWorld.cur_nonce) )
  /\ (forall u_id u rec_u_id rec_u,
        u_id <> rec_u_id
        -> usrs $? u_id = Some u
        -> usrs $? rec_u_id = Some rec_u
        -> honest_nonce_tracking_ok cs (RealWorld.findUserKeys usrs)
                                   (Some u_id)
                                   u.(RealWorld.sent_nons)
                                   u.(RealWorld.cur_nonce)
                                   rec_u_id rec_u.(RealWorld.from_nons)
                                   rec_u.(RealWorld.msg_heap)).

Definition universe_ok {A B} (U : RealWorld.universe A B) : Prop :=
  let honestk := RealWorld.findUserKeys U.(RealWorld.users)
  in  encrypted_ciphers_ok honestk U.(RealWorld.all_ciphers) U.(RealWorld.all_keys)
    /\ keys_and_permissions_good U.(RealWorld.all_keys) U.(RealWorld.users) U.(RealWorld.adversary).(RealWorld.key_heap)
    /\ user_cipher_queues_ok U.(RealWorld.all_ciphers) honestk U.(RealWorld.users)
    /\ message_queues_ok U.(RealWorld.all_ciphers) U.(RealWorld.users) U.(RealWorld.all_keys)
    /\ adv_cipher_queue_ok U.(RealWorld.all_ciphers) U.(RealWorld.users) U.(RealWorld.adversary).(RealWorld.c_heap)
    /\ adv_message_queue_ok U.(RealWorld.users) U.(RealWorld.all_ciphers) U.(RealWorld.all_keys) U.(RealWorld.adversary).(RealWorld.msg_heap)
    /\ adv_no_honest_keys honestk U.(RealWorld.adversary).(RealWorld.key_heap)
    /\ honest_nonces_ok U.(RealWorld.all_ciphers) U.(RealWorld.users)
    /\ honest_users_only_honest_keys U.(RealWorld.users).

Section Simulation.
  Variable A B : type.
  Variable advP : RealWorld.user_data B -> Prop.
  Variable R : RealWorld.simpl_universe A -> IdealWorld.universe A -> Prop.

  Definition simulates_silent_step :=
    forall (U__r : RealWorld.universe A B) U__i,
      R (RealWorld.peel_adv U__r) U__i
    -> universe_ok U__r
    -> advP U__r.(RealWorld.adversary)
    -> forall suid U__r',
        RealWorld.step_universe suid U__r Silent U__r'
        -> exists U__i',
          istepSilent ^* U__i U__i'
        /\ R (RealWorld.peel_adv U__r') U__i'.

  Definition simulates_labeled_step :=
    forall (U__r : RealWorld.universe A B) U__i,
      R (RealWorld.peel_adv U__r) U__i
    -> universe_ok U__r
    -> advP U__r.(RealWorld.adversary)
    -> forall uid U__r' ra,
        indexedRealStep uid (Action ra) U__r U__r'
        -> exists ia U__i' U__i'',
            (indexedIdealStep uid Silent) ^* U__i U__i'
            /\ indexedIdealStep uid (Action ia) U__i' U__i''
            /\ action_matches U__r.(RealWorld.all_ciphers) U__r.(RealWorld.all_keys) (uid,ra) ia
            /\ R (RealWorld.peel_adv U__r') U__i''.

  Definition honest_actions_safe :=
    forall (U__r : RealWorld.universe A B) U__i,
        R (RealWorld.peel_adv U__r) U__i
      -> universe_ok U__r
      -> honest_cmds_safe U__r.

  Definition ri_final_actions_align :=
    forall (U__r : RealWorld.universe A B) U__i,
      R (RealWorld.peel_adv U__r) U__i
      -> universe_ok U__r
      -> (forall uid lbl U__r', RealWorld.step_universe (Some uid) U__r lbl U__r' -> False)
      -> forall uid ud__r r__r,
          U__r.(RealWorld.users) $? uid = Some ud__r
          -> ud__r.(RealWorld.protocol) = RealWorld.Return r__r
          -> exists (U__i' : IdealWorld.universe A) ud__i r__i,
              istepSilent ^* U__i U__i'
              /\ U__i'.(IdealWorld.users) $? uid = Some ud__i
              /\ ud__i.(IdealWorld.protocol) = IdealWorld.Return r__i
              /\ Rret_val_to_val r__r = Iret_val_to_val r__i.

  Definition simulates (U__r : RealWorld.universe A B) (U__i : IdealWorld.universe A) :=

    (* conditions for simulation steps *)
    simulates_silent_step
  /\ simulates_labeled_step
  /\ honest_actions_safe
  /\ ri_final_actions_align

  (* conditions for start *)
  /\ R (RealWorld.peel_adv U__r) U__i
  /\ universe_ok U__r
  .

End Simulation.

Section IISimulation.
  Import IdealWorld.

  Variable A : type.
  Variable R : universe A -> universe A -> Prop.

  Definition ii_final_labels_align (U__i U__is : universe A) :=
    (forall lbl U__i', ~ lstep_universe U__i lbl U__i')
    -> exists (U__is' U__is'' : universe A),
      trc3 lstep_universe (fun _ => True) U__is U__is'
      /\ (forall lbl U__is'', ~ lstep_universe U__is' lbl U__is'')
      /\ forall uid ud__i r,
          U__i.(users) $? uid = Some ud__i
          -> ud__i.(protocol) = Return r
          -> exists ud__is,
            U__is'.(users) $? uid = Some ud__is
          /\ ud__is.(protocol) = Return r.

  Definition ii_step :=
    forall (U__i : universe A) U__is,
      R U__i U__is
      -> forall lbl U__i',
        lstep_universe U__i lbl U__i'
        -> exists U__is',
          trc3 lstep_universe (fun _ => True) U__is U__is'
          /\ ii_final_labels_align U__i' U__is'
          /\ R U__i' U__is'.

  Definition ii_simulates (U__i U__is : universe A) :=
    ii_step
    /\ R U__i U__is.

End IISimulation.

Definition refines {A B} (advP : RealWorld.user_data B -> Prop) (U1 : RealWorld.universe A B) (U2 : IdealWorld.universe A) :=
  exists R, simulates advP R U1 U2.

Notation "u1 <| u2 \ p " := (refines p u1 u2) (no associativity, at level 70).

Definition lameAdv {B} (b : RealWorld.denote (RealWorld.Base B)) :=
  fun adv => adv.(RealWorld.protocol) = @RealWorld.Return (RealWorld.Base B) b.

Definition awesomeAdv : forall B, RealWorld.user_data B -> Prop :=
  fun _ _ => True.


(* begin hide *)
From Coq Require Import
     String Morphisms List.

From ITree Require Import
     ITree
     Basics.Monad
     Eq.Eq
     TranslateFacts
     Events.State.

From Vellvm Require Import
     Utilities
     Syntax
     Semantics
     Utils.NoFailure
     Utils.PostConditions
     Theory.InterpreterCFG
     Theory.ExpLemmas
     Theory.InstrLemmas
     Theory.InterpreterCFG
     Theory.SymbolicInterpreter.

From ExtLib Require Import
     Core.RelDec
     Data.Map.FMapAList
     Structures.Maps.

Import ListNotations.
Import AlistNotations.
Import ITreeNotations.
Import SemNotations.
(* end hide *)

(** * Live-equivalence
    Optimizations do not preserve functional equivalence of local environment in general.
 *)

From Coq Require Import ListSet.
Import SetNotations.
Import AlistNotations.

Definition local_agrees (l1 l2 : local_env) (scope : set raw_id) : Prop :=
  forall id, In id scope -> l1 @ id = l2 @ id.

Section UpwardExposed.

  (** * Upward exposed
        A use site is said to be upward exposed if its def site is not in the
        same block, i.e. if the live range of the used variable escapes the block
        of the use site.
   *)
  (* Note: this definition is quite naive, it doesn't consider the relative position
       within the block of the def and use sites considered.
       I believe that it's correct in SSA form, but should be triple checked.
   *)

  Definition upward_exposed {T} (bk : block T) : set raw_id :=
    use_sites bk ∖ def_sites bk.

End UpwardExposed.

Section Block_Substitution.

  (* This definition expresses the local proof obligation
     required to justify the substitution of a block [b1]
     by another block [b2] in a context.
     Contrary to the case of equivalent expressions, the
     context will be constrained as well.
     We state that if:
     - the upward exposed local variables are the same set
     [scope] in both blocks.
     - the initial local states extensionally agree on [scope]
     then:
     - the blocks are bisimilar
     - they return local states that extensionally agree on
   *)

  Definition local_post :

  Definition block_equivalence :
    forall (b1 b2 : block dtyp) scope_in scope_out,
      upward_exposed b1 = scope_in -> (* To replace with bijection *)
      upward_exposed b2 = scope_out -> (* To replace with bijection *)
      forall g l1 l2 m bin,
        local_agrees l1 l2 scope_in ->
        eutt (fun '(m1,(l,(g,v)))
             (⟦ b1 ⟧b3 bin g l1 m)
             (⟦ b2 ⟧b3 bin g l2 m).

(* Definition lift_localR (R : local_env -> local_env -> Prop) : *)

End Block_Substitution.

(*
If pre = post = RS

relS := S -> S -> Prop

Any monad that is worth its name should come with an instance of eqmR.
S -> M (S * _)
EQMRBUILDER : relS -> relS -> eqmR_sig

Definition equiv (X Y S : Type) (pre post : S -> S -> Prop) (R : X -> Y -> Prop)
  : StateT S (itree E) X -> StateT S (itree E) Y -> Prop :=
  fun c1 c2 =>
    forall s1 s2,
      pre s1 s2 -> eutt (post * R) (c1 s1) (c2 s2).

(* forall R' *)
eqmr R' c1 c2
forall v1 v2, R' v v' -> eqmr R (k1 v1) (k2 v2)
==============================
eqmr R (bind c1 k1) (bind c2 k2)

hoaremR ~> (S -> S -> Prop) -> (S -> S -> Prop) -> eqmR_sig

(* forall R' (inter : S -> S -> Prop) *)
equiv pre inter R' c1 c2
forall v1 v2, R' v1 v2 -> equiv inter post R (k1 v1) (k2 v2)
==============================
equiv pre post R (bind c1 k1) (bind c2 k2)

 *)

Section Liveness.

  (** * Liveness
      Data-flow approach, we compute for each block the [LiveIn] set of live variables when entering the block,
      and [LiveOut] set of live variables when entering a successor of the block.
      These sets can be characterized by the following set of recursive equations:
      LiveIn bk  ≡ defs bk.(blk_phis) +++ upward_exposed bk +++ (LiveOut bk ∖ defs bk)
      LiveOut bk ≡ (set_flat_map (fun bk' => LiveIn bk' ∖ defs bk'.(blk_phis)) (bk_outputs bk)) +++ uses bk.(blk_phis)
      In SSA form, the fixpoint can be directly computed in two passses over the CFG.
   *)

End Liveness.