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.