Require Export QueryStructureNotations QueryQSSpecs.
Require Import List Compare_dec AdditionalLemmas
        AdditionalPermutationLemmas AdditionalMorphisms
        EnsembleListEquivalenceProperties flattenCompListProperties
        GeneralQueryRefinements.

Unset Implicit Arguments.

Transparent Count Query_For.

Ltac subst_strings :=
  repeat match goal with
           | [ H : string |- _ ] => subst H
           | [ H : BoundedIndex _ |- _ ] => subst H
         end.

Ltac pose_string_ids :=
  subst_strings;
  repeat match goal with
           | |- context [String ?R ?R'] =>
             let str := fresh "StringId" in
             set (String R R') as str in *
           | |- context [ ``(?R) ] =>
             let idx := fresh in
             set ``(R) as fresh in *
         end.

Section ConstraintCheckRefinements.
  Hint Resolve AC_eq_nth_In AC_eq_nth_NIn crossConstr.
  Hint Unfold SatisfiesCrossRelationConstraints
       SatisfiesSchemaConstraints.

  Fixpoint app_assoc {A : Set} (As As' As'' : list A):
      As ++ (As' ++ As'') = (As ++ As') ++ As'' :=
    match As as As return
                  As ++ (As' ++ As'') = (As ++ As') ++ As'' with
              | [] => eq_refl _
              | a :: As => (f_equal (fun l => a :: l) (app_assoc As As' As''))
            end.

  Lemma app_comm_cons' {A : Set}:
    forall (a : A) As As',
      As ++ (a :: As') = (As ++ [a]) ++ As'.
  Proof.
    intros; rewrite <- app_assoc; reflexivity.
  Defined.

  Definition Ensemble_BoundedIndex_app_comm_cons {A : Set}
    (a : A)
    (As As' : list A)
    (P : Ensemble (BoundedIndex (As ++ a :: As')))
  : Ensemble (BoundedIndex ((As ++ [a]) ++ As')).
    rewrite app_comm_cons' in P; exact P.
  Defined.

  Definition BoundedIndex_app_comm_cons {A : Set}
    (a : A)
    (As As' : list A)
    (a' : BoundedIndex (As ++ a :: As'))
  : BoundedIndex ((As ++ [a]) ++ As').
    rewrite app_comm_cons' in a'; exact a'.
  Defined.

  Lemma ibound_BoundedIndex_app_comm_cons {A : Set}
    (a : A)
    (As As' : list A)
    (a' : BoundedIndex (As ++ a :: As'))
  : ibound a' = ibound (BoundedIndex_app_comm_cons a As As' a').
  Proof.
    unfold BoundedIndex_app_comm_cons, eq_rec, eq_rect; simpl.
    destruct (app_comm_cons' a As As'); reflexivity.
  Qed.

  Program Fixpoint Iterate_Ensemble_BoundedIndex'
          {A : Set}
          (Visited Remaining : list A)
          (P : Ensemble (BoundedIndex (Visited ++ Remaining))) : Prop :=
    match Remaining with
        | [] => True
        | a :: Remaining' =>
          P {| bindex := a;
               indexb := {| ibound := List.length Visited;
                            boundi := _ |} |}
          /\ Iterate_Ensemble_BoundedIndex' (Visited ++ (a :: nil)) Remaining' _
    end.
  Next Obligation.
    clear P; induction Visited; simpl; auto.
  Defined.
  Next Obligation.
    exact (Ensemble_BoundedIndex_app_comm_cons _ _ _ P).
  Defined.

  (* Iterating with a filter. *)
  Program Fixpoint Iterate_Ensemble_BoundedIndex_filter'
          {A : Set}
          (Visited Remaining : list A)
          (filter : nat -> bool)
          (P : Ensemble (BoundedIndex (Visited ++ Remaining))) : Prop :=
    match Remaining with
        | [] => True
        | a :: Remaining' =>
          if filter (List.length Visited)
          then
            P {| bindex := a;
                 indexb := {| ibound := List.length Visited;
                              boundi := _ |} |}
            /\ Iterate_Ensemble_BoundedIndex_filter' (Visited ++ (a :: nil)) Remaining' filter _
          else
            Iterate_Ensemble_BoundedIndex_filter' (Visited ++ (a :: nil)) Remaining' filter _
    end.
  Next Obligation.
    clear filter P; induction Visited; simpl; auto.
  Defined.
  Next Obligation.
    exact (Ensemble_BoundedIndex_app_comm_cons _ _ _ P).
  Defined.
  Next Obligation.
    exact (Ensemble_BoundedIndex_app_comm_cons _ _ _ P).
  Defined.

  Lemma Ensemble_BoundedIndex_app_equiv {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
        (a : A) (As As' : list A)
        (P : Ensemble (BoundedIndex (As ++ a :: As')))
  : forall idx idx' n nth nth',
      P {| bindex := idx; indexb := {| ibound := n; boundi := nth |}|} <->
      Ensemble_BoundedIndex_app_comm_cons a As As' P
                                     {| bindex := idx'; indexb := {| ibound := n; boundi := nth' |}|}.
  Proof.
    split; unfold Ensemble_BoundedIndex_app_comm_cons, BoundedIndex_app_comm_cons, app_comm_cons'; simpl;
    unfold eq_rec, eq_rect, eq_ind, eq_rect; destruct (app_assoc As [a] As'); auto;
    generalize (indexb_ibound_eq
            {| bindex := idx'; indexb := {| ibound := n; boundi := nth' |}|}
            {| bindex := idx; indexb := {| ibound := n; boundi := nth |}|}
            eq_refl); simpl; intros; subst;
    erewrite (eq_proofs_unicity_Opt_A A_eq_dec _); eauto.
  Qed.

  Lemma BoundedIndex_app_comm_cons_nth_eq {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall
      (As As' : list A)
      a a' a'' n nth nth',
      {| bindex := a; indexb := {| ibound := n; boundi := nth |}|} =
      BoundedIndex_app_comm_cons a' As As' {| bindex := a''; indexb := {| ibound := n; boundi := nth' |}|}.
  Proof.
    intros.
    unfold BoundedIndex_app_comm_cons, eq_rec, eq_rect; simpl.
    destruct (app_comm_cons' a' As As').
    generalize (indexb_ibound_eq
            {| bindex := a''; indexb := {| ibound := n; boundi := nth' |}|}
            {| bindex := a; indexb := {| ibound := n; boundi := nth |}|}
               eq_refl); simpl; intros; subst.
    erewrite (eq_proofs_unicity_Opt_A A_eq_dec nth'); reflexivity.
  Qed.

  Lemma Ensemble_BoundedIndex_nth_eq {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall
      (As : list A)
      (P : Ensemble (BoundedIndex As))
      a a' n nth nth',
      P {| bindex := a; indexb := {| ibound := n; boundi := nth |}|} ->
      P {| bindex := a'; indexb := {| ibound := n; boundi := nth' |}|}.
  Proof.
    intros;
    generalize (indexb_ibound_eq
            {| bindex := a'; indexb := {| ibound := n; boundi := nth' |}|}
            {| bindex := a; indexb := {| ibound := n; boundi := nth |}|}
               eq_refl); simpl; intros; subst.
    erewrite (eq_proofs_unicity_Opt_A A_eq_dec nth'); eassumption.
  Qed.

  Lemma nth_error_app {A : Set} :
    forall (a : A) (As As' : list A) n,
      nth_error As n = Some a ->
      nth_error (As ++ As') n = Some a.
  Proof.
    induction As; destruct n; simpl; intros; try discriminate; auto.
  Defined.

  Lemma Ensemble_nth_error_app
        {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall a (As As' : list A) nth'
      (P : Ensemble (BoundedIndex (As ++ (a :: As')))),
      P {| bindex := a;
           indexb := {| ibound := Datatypes.length As;
                        boundi := nth' |} |}
      -> (forall (a' : A) (n : nat) (nth : nth_error As n = Some a'),
      P {| bindex := a';
           indexb := {|
                      ibound := n;
                      boundi := nth_error_app _ As (a :: As') n nth |} |})
      -> forall (a' : A) (n : nat) (nth : nth_error (As ++ [a]) n = Some a'),
           Ensemble_BoundedIndex_app_comm_cons a As As' P
                                          {| bindex := a';
                                             indexb := {| ibound := n;
                                                          boundi := nth_error_app _ (As ++ [a]) As' n nth |} |}.
  Proof.
    intros.
    destruct (eq_nat_dec (List.length As) n ); subst.
    - rewrite (BoundedIndex_app_comm_cons_nth_eq
                 A_eq_dec As As' _ _ _  (List.length As)
                 (nth_error_app _ (As ++ [a]) As'
                                (Datatypes.length As) nth)
                 nth').
      erewrite <- BoundedIndex_app_comm_cons_nth_eq; eauto.
      eapply Ensemble_BoundedIndex_app_equiv; eauto.
    - assert (nth_error As n = Some a') by
          (revert n nth n0; clear; induction As; destruct n; simpl; intros;
           try congruence;
           [destruct n; discriminate
           | eauto]).
      generalize (H0 _ _ H1); intros.
      erewrite (BoundedIndex_app_comm_cons_nth_eq
                 A_eq_dec As As' _ _ _ n
                 (nth_error_app _ (As ++ [a]) As'
                                n nth)).
      erewrite <- BoundedIndex_app_comm_cons_nth_eq; eauto.
      eapply Ensemble_BoundedIndex_app_equiv; eauto.
      Grab Existential Variables.
      rewrite <- app_assoc; simpl; apply nth_error_app; eassumption.
      apply nth_error_app; eassumption.
      apply nth_error_app; eassumption.
  Qed.

  Lemma Ensemble_nth_error_app_filter
        {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall a (As As' : list A) nth'
           (P : Ensemble (BoundedIndex (As ++ (a :: As'))))
           (filter : Ensemble nat)
           (filter_dec : DecideableEnsemble filter),
      (filter (Datatypes.length As) ->
       P {| bindex := a;
            indexb := {| ibound := Datatypes.length As;
                         boundi := nth' |} |})
      -> (forall (a' : A) (n : nat) (nth : nth_error As n = Some a'),
            filter n ->
            P {| bindex := a';
                 indexb := {|
                            ibound := n;
                            boundi := nth_error_app _ As (a :: As') n nth |} |})
      -> forall (a' : A) (n : nat) (nth : nth_error (As ++ [a]) n = Some a'),
           filter n ->
           Ensemble_BoundedIndex_app_comm_cons a As As' P
                                          {| bindex := a';
                                             indexb := {| ibound := n;
                                                          boundi := nth_error_app _ (As ++ [a]) As' n nth |} |}.
  Proof.
    intros.
    destruct (eq_nat_dec (List.length As) n ); subst.
    - rewrite (BoundedIndex_app_comm_cons_nth_eq
                 A_eq_dec As As' _ _ _  (List.length As)
                 (nth_error_app _ (As ++ [a]) As'
                                (Datatypes.length As) nth)
                 nth').
      erewrite <- BoundedIndex_app_comm_cons_nth_eq; eauto.
      eapply Ensemble_BoundedIndex_app_equiv; auto.
    - assert (nth_error As n = Some a') by
          (generalize n nth n0; clear; induction As; destruct n; simpl; intros;
           try congruence;
           [destruct n; discriminate
           | eauto]).
      generalize (H0 _ _ H2 H1); intros.

      erewrite (BoundedIndex_app_comm_cons_nth_eq
                 A_eq_dec As As' _ _ _ n
                 (nth_error_app _ (As ++ [a]) As'
                                n nth)).
      erewrite <- BoundedIndex_app_comm_cons_nth_eq; eauto.
      eapply Ensemble_BoundedIndex_app_equiv; eauto.
      Grab Existential Variables.
      rewrite <- app_assoc; simpl; apply nth_error_app; eassumption.
      apply nth_error_app; eassumption.
      apply nth_error_app; eassumption.
  Qed.

  Lemma Iterate_Ensemble_equiv' {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : Ensemble (BoundedIndex (Visited ++ Remaining))),
      (forall a n (nth : nth_error Visited n = Some a),
         P {| bindex := a;
              indexb := {| ibound := n;
                           boundi := nth_error_app _ _ _ _ nth |} |})
      -> (Iterate_Ensemble_BoundedIndex' Visited Remaining P ->
         forall idx, P idx).
    intros; destruct idx as [idx [n nth_n] ]; simpl in *.
    revert Visited P H H0 idx n nth_n; induction Remaining; simpl; intros.
    - eapply Ensemble_BoundedIndex_nth_eq with (a := idx); auto.
    - split_and.
      assert (nth_error ((Visited ++ [a]) ++ Remaining) n = Some idx)
        as nth_n'
          by (rewrite <- app_assoc; simpl; assumption).
      generalize (IHRemaining _ _ (Ensemble_nth_error_app A_eq_dec _ _ _ _ P H1 H) H2 _ _ nth_n').
      unfold Ensemble_BoundedIndex_app_comm_cons, eq_rect; destruct (app_comm_cons' a Visited Remaining).
      intros; erewrite (eq_proofs_unicity_Opt_A A_eq_dec nth_n); eauto.
      Grab Existential Variables.
      rewrite app_nil_r in nth_n; assumption.
  Qed.

  Lemma Iterate_Ensemble_equiv'' {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : Ensemble (BoundedIndex (Visited ++ Remaining))),
      (forall idx, P idx)
      -> Iterate_Ensemble_BoundedIndex' Visited Remaining P.
    induction Remaining; simpl; auto.
    intros; split; eauto.
    eapply IHRemaining; intros; eauto.
    intros; destruct idx as [idx [n nth_n] ]; simpl in *.
    eapply Ensemble_BoundedIndex_app_equiv; eauto.
    Grab Existential Variables.
    rewrite <- app_assoc in nth_n; simpl in nth_n; eassumption.
  Qed.

  Lemma Iterate_Ensemble_equiv_filter' {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : Ensemble (BoundedIndex (Visited ++ Remaining)))
           (filter : Ensemble nat)
           (filter_dec : DecideableEnsemble filter),
      (forall a n (nth : nth_error Visited n = Some a),
         filter n ->
         P {| bindex := a;
              indexb := {| ibound := n;
                           boundi := nth_error_app _ _ _ _ nth |} |})
      -> (Iterate_Ensemble_BoundedIndex_filter' Visited Remaining
                                              (@dec _ _ filter_dec) P ->
          forall idx, filter (ibound (indexb idx)) -> P idx).
  Proof.
    intros; destruct idx as [idx [n nth_n] ]; simpl in *.
    revert Visited filter filter_dec P H H0 idx n nth_n H1;
      induction Remaining; simpl; intros.
    - eapply Ensemble_BoundedIndex_nth_eq with (a := idx); auto.
    - revert H0; case_eq (dec (Datatypes.length Visited)); intros.
      + split_and.
        assert (nth_error ((Visited ++ [a]) ++ Remaining) n = Some idx)
          as nth_n'
            by (rewrite <- app_assoc; simpl; assumption).
        generalize (IHRemaining
                      _ filter filter_dec _
                      (Ensemble_nth_error_app_filter
                         A_eq_dec _ _ _ _ P
                         filter filter_dec (fun _ => H3) H)
                      H4 _ _ nth_n').
        unfold Ensemble_BoundedIndex_app_comm_cons, eq_rect.
        destruct (app_comm_cons' a Visited Remaining).
        clear H.
        intros; erewrite (eq_proofs_unicity_Opt_A A_eq_dec nth_n); eauto.
      + assert (nth_error ((Visited ++ [a]) ++ Remaining) n = Some idx)
        as nth_n'
          by (rewrite <- app_assoc; simpl; assumption).
        assert (forall P, filter (Datatypes.length Visited) -> P)
          as H' by
              (intros P' filt_a; apply dec_decides_P in filt_a;
               congruence).
        assert (nth_error (Visited ++ (a :: Remaining))
                           (Datatypes.length Visited) = Some a)
               as nth_a
                 by (clear; induction Visited; simpl; auto).
        generalize (IHRemaining
                    _ filter filter_dec _
                    (Ensemble_nth_error_app_filter
                       A_eq_dec _ _ _ nth_a P
                       filter filter_dec (H' _) H)
                    H2 _ _ nth_n').
      unfold Ensemble_BoundedIndex_app_comm_cons, eq_rect.
      destruct (app_comm_cons' a Visited Remaining).
      clear H.
      intros; erewrite (eq_proofs_unicity_Opt_A A_eq_dec nth_n); eauto.
      Grab Existential Variables.
      rewrite app_nil_r in nth_n; assumption.
  Qed.

  Lemma Iterate_Ensemble_equiv_filter'' {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : Ensemble (BoundedIndex (Visited ++ Remaining)))
           (filter : Ensemble nat)
           (filter_dec : DecideableEnsemble filter),
      (forall idx, filter (ibound (indexb idx)) -> P idx)
      -> Iterate_Ensemble_BoundedIndex_filter'
           Visited Remaining
           (@dec _ _ filter_dec) P.
  Proof.
    induction Remaining; simpl; auto.
    intros; case_eq (dec (Datatypes.length Visited)); try split; eauto.
    - eapply H; apply dec_decides_P; simpl; auto.
    - eapply IHRemaining; intros; eauto.
      intros; destruct idx as [idx [n nth_n] ]; simpl in *.
      eapply Ensemble_BoundedIndex_app_equiv; eauto.
    - intros; eapply IHRemaining; intros; eauto.
      intros; destruct idx as [idx [n nth_n] ]; simpl in *.
      eapply Ensemble_BoundedIndex_app_equiv; eauto.
    Grab Existential Variables.
    rewrite <- app_assoc in nth_n; simpl in nth_n; eassumption.
    rewrite <- app_assoc in nth_n; simpl in nth_n; eassumption.
  Qed.

  Definition Iterate_Ensemble_BoundedIndex
          (Bound : list string)
          (P : Ensemble (BoundedIndex Bound)) : Prop :=
    Iterate_Ensemble_BoundedIndex' [] Bound P.

  Definition Iterate_Ensemble_BoundedIndex_filter
          (Bound : list string)
          (filter : nat -> bool)
          (P : Ensemble (BoundedIndex Bound))
  : Prop :=
    Iterate_Ensemble_BoundedIndex_filter' [] Bound filter P.

  Lemma refine_Iterate_Ensemble {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (As : list string)
           (P : Ensemble (BoundedIndex As)),
      refine {b | decides b (forall idx : BoundedIndex As, P idx)}
             {b | decides b (@Iterate_Ensemble_BoundedIndex As P)}.
  Proof.
    intros; eapply refine_pick_pick.
    intros; destruct x; simpl in *.
    intros; eapply Iterate_Ensemble_equiv' with (Visited := []);
    eauto using string_dec.
    destruct n; simpl; intros; discriminate.
    unfold not; intros; apply H.
    apply Iterate_Ensemble_equiv'';
      auto using string_dec.
  Qed.

  Lemma refine_Iterate_Ensemble_filter {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (As : list string)
           (P : Ensemble (BoundedIndex As))
           (filter : Ensemble nat)
           (filter_dec : DecideableEnsemble filter),
      refine {b | decides b (forall idx : BoundedIndex As,
                               filter (ibound idx) -> P idx)}
             {b | decides b (@Iterate_Ensemble_BoundedIndex_filter
                               As (@dec _ _ filter_dec) P )}.
  Proof.
    intros; eapply refine_pick_pick.
    intros; destruct x; simpl in *.
    intros; eapply Iterate_Ensemble_equiv_filter' with (Visited := []);
    eauto using string_dec.
    destruct n; simpl; intros; discriminate.
    unfold not; intros; apply H.
    apply Iterate_Ensemble_equiv_filter''; auto using string_dec.
  Qed.

  Lemma refine_decides_Equiv_Ensemble {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (As : list string)
           (P P' : Ensemble (BoundedIndex As))
           (equiv_P'_P : (forall idx, P idx) <-> (forall idx', P' idx')),
      refine {b | decides b (forall idx : BoundedIndex As, P idx)}
             {b | decides b (forall idx : BoundedIndex As, P' idx)}.
  Proof.
    intros * equiv_P'_P v Comp_v.
    inversion_by computes_to_inv; constructor; destruct v; simpl in *.
    intros; eapply equiv_P'_P; eauto.
    unfold not; intros; eapply Comp_v; eapply equiv_P'_P; eauto.
  Qed.

  Corollary Iterate_Ensemble_filter_neq {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (As : list string)
           (P : Ensemble (BoundedIndex As))
           (Ridx : BoundedIndex As),
    (forall idx : BoundedIndex As, idx <> Ridx -> P idx)
    <-> (@Iterate_Ensemble_BoundedIndex_filter
           As (fun idx =>
                 if (eq_nat_dec (ibound Ridx) idx)
                 then false else true) P ).
  Proof.
    intros.
    assert (forall a : nat,
              (if eq_nat_dec (ibound Ridx) a then false else true) = true
              <-> a <> ibound Ridx)
      as filter_dec'
      by (intros; find_if_inside; try rewrite e; intuition).
    assert ((forall idx : BoundedIndex As, idx <> Ridx -> P idx)
            <-> (forall idx  : BoundedIndex As,
                   ibound idx <> ibound Ridx -> P idx)).
    { split; intros; eauto.
      apply H; destruct idx as [idx [n nth_n] ];
      destruct Ridx as [Ridx [n' nth_n'] ]; simpl in *.
      unfold not; intros; apply H0; injection H1; auto.
      apply H; unfold not; intros; apply H0.
      destruct idx as [idx [n nth_n] ];
        destruct Ridx as [Ridx [n' nth_n'] ]; simpl in *.
      clear H0; revert nth_n; rewrite H1; intros.
      assert (Ridx = idx) by
          (rewrite nth_n' in nth_n; congruence).
      revert nth_n' nth_n; rewrite H0.
      intros; repeat f_equal.
      apply (eq_proofs_unicity_Opt_A string_dec).
    }
    rewrite H.
    split; intros.
    - eapply Iterate_Ensemble_equiv_filter'' with
      (filter := fun idx => idx <> ibound Ridx)
        (filter_dec := {|dec_decides_P := filter_dec' |}); eauto.
      apply string_dec.
    - eapply Iterate_Ensemble_equiv_filter'  with
      (Visited := [])
      (filter := fun idx => idx <> ibound Ridx)
        (filter_dec := {|dec_decides_P := filter_dec' |});
      unfold dec; eauto using string_dec.
      intros; destruct n; simpl in *; discriminate.
  Qed.

  Lemma refine_Iterate_Equiv_Ensemble {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (As As' : list string)
           (P : Ensemble (BoundedIndex As))
           (P' : Ensemble (BoundedIndex As'))
           (equiv_P'_P : (forall idx, P idx) <-> (forall idx', P' idx')),
      refine {b | decides b (forall idx : BoundedIndex As, P idx)}
             {b | decides b (@Iterate_Ensemble_BoundedIndex As' P')}.
  Proof.
    intros; setoid_rewrite refine_Iterate_Ensemble; try eassumption.
    intros v Comp_v.
    inversion_by computes_to_inv; constructor; destruct v; simpl in *.
    apply Iterate_Ensemble_equiv'' with (Visited := []);
      eauto using string_dec; simpl.
    apply equiv_P'_P; intros;
    apply Iterate_Ensemble_equiv' with (Visited := []);
    eauto using string_dec; simpl.
    destruct n; simpl; intros; discriminate.
    unfold not; intros; apply Comp_v.
    apply Iterate_Ensemble_equiv'';
      auto using string_dec.
    apply equiv_P'_P;
    apply Iterate_Ensemble_equiv' with (Visited := []);
    eauto using string_dec; simpl.
    destruct n; simpl; intros; discriminate.
  Qed.

  (* So that things play nicely with setoid rewriting *)
  Definition If_Then_Else {A}  (b : bool) (t e : A)
    := if b then t else e.

  Program Fixpoint Iterate_Decide_Comp' (A : Set)
          (Remaining Visited : list A)
          (P : Ensemble (BoundedIndex (Visited ++ Remaining)))
          {struct Remaining }
  : Comp bool :=
    match Remaining with
      | nil => ret true
      | cons a Remaining' =>
        Bind {b' |
              decides b' (P {| bindex := a;
                               indexb := {| ibound := List.length Visited;
                                            boundi := _ |} |})}%comp
             (fun b' =>
                If_Then_Else b'
                             (Iterate_Decide_Comp' _ Remaining' (Visited ++ [a]) _)
                             (ret false))
    end.
  Next Obligation.
    clear P; induction Visited; simpl; auto.
  Defined.
  Next Obligation.
    exact (Ensemble_BoundedIndex_app_comm_cons _ _ _ P).
  Defined.

  Lemma refine_Iterate_Decided_Ensemble' {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : Ensemble (BoundedIndex (Visited ++ Remaining))),
      refine {b | decides b (Iterate_Ensemble_BoundedIndex' Visited Remaining P)}
             (Iterate_Decide_Comp' _ Remaining Visited P).
  Proof.
    induction Remaining; simpl; intros.
    - econstructor; inversion_by computes_to_inv; subst; simpl; auto.
    - econstructor; apply computes_to_inv in H; destruct_ex;
      split_and; inversion_by computes_to_inv; subst.
      destruct x; simpl in *.
      {  destruct v; simpl in *; intuition; intros; eauto.
         - generalize (IHRemaining (Visited ++ [a]) _ _ H1).
           intros; inversion_by computes_to_inv; simpl in *; eauto.
         - generalize (IHRemaining (Visited ++ [a]) _ _ H1).
           intros; inversion_by computes_to_inv; simpl in *; eauto.
      }
      { inversion_by computes_to_inv; subst; simpl; intuition. }
  Qed.

  Definition Iterate_Decide_Comp
          (Bound : list string)
          (P : Ensemble (BoundedIndex Bound))
  : Comp bool :=
    Iterate_Decide_Comp' _ Bound [] P.

  Definition Iterate_Decide_Comp_BoundedIndex
  : forall (Bound : list string)
           (P : Ensemble (BoundedIndex Bound)),
      refine {b | decides b (forall Ridx', P Ridx')}
             (Iterate_Decide_Comp _ P).
  Proof.
    intros.
    setoid_rewrite refine_Iterate_Ensemble; auto using string_dec.
    setoid_rewrite refine_Iterate_Decided_Ensemble'; auto using string_dec.
    reflexivity.
  Qed.

  (* Variants for inserting additional assumptions into the
   decision procedure. *)
  Program Lemma refine_Iterate_Ensemble_Pre {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (As : list string)
           (P : Ensemble (BoundedIndex As))
           (Q : Prop),
      refine {b | Q -> decides b (forall idx : BoundedIndex As, P idx)}
             {b | Q -> decides b (@Iterate_Ensemble_BoundedIndex As P)}.
  Proof.
    intros; eapply refine_pick_pick.
    intros; destruct x; simpl in *; apply H in H0.
    intros; eapply Iterate_Ensemble_equiv' with (Visited := []);
    eauto using string_dec.
    destruct n; simpl; intros; discriminate.
    unfold not; intros; apply H0.
    apply Iterate_Ensemble_equiv'';
      auto using string_dec.
  Qed.

  Program Fixpoint Iterate_Decide_Comp'_Pre (A : Set)
          (Remaining Visited : list A)
          (P : Ensemble (BoundedIndex (Visited ++ Remaining)))
          (Q : Prop)
          {struct Remaining }
  : Comp bool :=
    match Remaining with
      | nil => ret true
      | cons a Remaining' =>
        Bind {b' | Q ->
              decides b' (P {| bindex := a;
                               indexb := {| ibound := List.length Visited;
                                            boundi := _ |} |})}%comp
             (fun b' =>
                If_Then_Else b'
                             (Iterate_Decide_Comp'_Pre _ Remaining' (Visited ++ [a]) _ Q)
                             (ret false))
    end.
  Next Obligation.
    clear P; induction Visited; simpl; auto.
  Defined.
  Next Obligation.
    exact (Ensemble_BoundedIndex_app_comm_cons _ _ _ P).
  Defined.

  Lemma refine_Iterate_Decided_Ensemble'_Pre {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : Ensemble (BoundedIndex (Visited ++ Remaining)))
           (Q : Prop),
      refine {b | Q -> decides b (Iterate_Ensemble_BoundedIndex' Visited Remaining P)}
             (Iterate_Decide_Comp'_Pre _ Remaining Visited P Q).
  Proof.
    induction Remaining; simpl; intros.
    - econstructor; inversion_by computes_to_inv; subst; simpl; auto.
    - econstructor; apply computes_to_inv in H; destruct_ex;
      split_and; inversion_by computes_to_inv; subst.
      destruct x; simpl in *.
      {  destruct v; simpl in *; intuition; intros; eauto.
         - generalize (IHRemaining (Visited ++ [a]) _ _ _ H1).
           intros; inversion_by computes_to_inv; simpl in *; eauto.
         - generalize (IHRemaining (Visited ++ [a]) _ _ _ H1).
           intros; inversion_by computes_to_inv; simpl in *; eauto.
           eapply H0; eauto.
      }
      { inversion_by computes_to_inv; subst; simpl; intuition. }
  Qed.

  Definition Iterate_Decide_Comp_Pre
          (Bound : list string)
          (P : Ensemble (BoundedIndex Bound))
          (Q : Prop)
  : Comp bool :=
    Iterate_Decide_Comp'_Pre _ Bound [] P Q.

  Definition Iterate_Decide_Comp_BoundedIndex_Pre
  : forall (Bound : list string)
           (P : Ensemble (BoundedIndex Bound))
           (Q : Prop),
      refine {b | Q -> decides b (forall Ridx', P Ridx')}
             (Iterate_Decide_Comp_Pre _ P Q).
  Proof.
    intros.
    setoid_rewrite refine_Iterate_Ensemble_Pre; auto using string_dec.
    setoid_rewrite refine_Iterate_Decided_Ensemble'_Pre; auto using string_dec.
    reflexivity.
  Qed.

  Lemma decides_True :
    refine {b | decides b True}%comp
           (ret true).
  Proof.
    econstructor; inversion_by computes_to_inv; subst; simpl; auto.
  Qed.

  Lemma decides_True_Pre (Q : Prop) :
    refine {b | Q -> decides b True}%comp
           (ret true).
  Proof.
    econstructor; inversion_by computes_to_inv; subst; simpl; auto.
  Qed.

  Lemma decides_2_True (A : Type) (B : A -> Type) :
    refine {b' | decides b' (forall a : A, B a -> True)}%comp
           (ret true).
  Proof.
    econstructor; inversion_by computes_to_inv; subst; simpl; auto.
  Qed.

  Lemma decides_3_True (A B : Type) (C : B -> Type) :
    refine {b' | decides b' (A -> forall b : B, C b -> True)}%comp
           (ret true).
  Proof.
    econstructor; inversion_by computes_to_inv; subst; simpl; auto.
  Qed.

  Lemma decides_neq (A : Type) (B : Prop) (a : A) :
    refine {b' | decides b' (a <> a -> B)}%comp
           (ret true).
  Proof.
    econstructor; inversion_by computes_to_inv; subst; simpl; auto.
    congruence.
  Qed.

  Global Add Parametric Morphism A
  : If_Then_Else
      with signature
      (@eq bool) ==> (@refine A) ==> (@refine A) ==> (@refine A)
        as refine_If_Then_Else_if.
  Proof.
    compute.
    intros; destruct_head bool; intros; eauto.
  Qed.

  Definition Ensemble_opt_BoundedIndex_app_comm_cons {A : Set}
    (a : A)
    (As As' : list A)
    (P : BoundedIndex (As ++ a :: As') -> option Prop)
  : BoundedIndex ((As ++ [a]) ++ As') -> option Prop.
    rewrite app_comm_cons' in P; exact P.
  Defined.

  Program Fixpoint Iterate_Decide_Comp_opt' (A : Set)
          (Remaining Visited : list A)
          (P : BoundedIndex (Visited ++ Remaining) -> option Prop )
          {struct Remaining }
  : Comp bool :=
    match Remaining with
      | nil => ret true
      | cons a Remaining' =>
        match (P {| bindex := a;
                    indexb := {| ibound := List.length Visited;
                                 boundi := _ |} |}) with
          | Some P' => b' <- {b' | decides b' P'};
                      If_Then_Else b'
                                   (Iterate_Decide_Comp_opt' _ Remaining' (Visited ++ [a])
                                                             (Ensemble_opt_BoundedIndex_app_comm_cons _ _ _ P))
                                   (ret false)
          | None => (Iterate_Decide_Comp_opt' _ Remaining' (Visited ++ [a])
                                              (Ensemble_opt_BoundedIndex_app_comm_cons _ _ _ P))
        end
    end%comp.
  Next Obligation.
    clear P; induction Visited; simpl; auto.
  Defined.

  Lemma refine_Iterate_Decide_Comp'
        {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : BoundedIndex (Visited ++ Remaining)
                -> option Prop),
      refine (@Iterate_Decide_Comp' _ Remaining Visited (fun idx => match P idx with
                                                                      | Some P' => P'
                                                                      | None => True
                                                                    end))
             (@Iterate_Decide_Comp_opt' _ Remaining Visited P).
    induction Remaining; simpl; intros.
    - reflexivity.
    - destruct (P ``(a)).
      + f_equiv; unfold pointwise_relation; intros.
        destruct a0; simpl; try reflexivity.
        setoid_rewrite <- IHRemaining; f_equiv.
        unfold Ensemble_BoundedIndex_app_comm_cons,
        Ensemble_opt_BoundedIndex_app_comm_cons; simpl.
        destruct (app_comm_cons' a Visited Remaining); simpl.
        reflexivity.
      + rewrite decides_True; simplify with monad laws; simpl.
        setoid_rewrite <- IHRemaining; f_equiv.
        unfold Ensemble_BoundedIndex_app_comm_cons,
        Ensemble_opt_BoundedIndex_app_comm_cons; simpl.
        destruct (app_comm_cons' a Visited Remaining); simpl.
        reflexivity.
  Qed.

  Lemma refine_Iterate_Decide_Comp
  : forall (Bound : list string)
           (P : BoundedIndex Bound -> option Prop),
      refine (@Iterate_Decide_Comp _ (fun idx => match P idx with
                                                 | Some P' => P'
                                                 | None => True
                                               end))
             (@Iterate_Decide_Comp_opt' _ Bound [] P).
  Proof.
    intros; unfold Iterate_Decide_Comp;
    rewrite refine_Iterate_Decide_Comp'.
    reflexivity.
    apply string_dec.
  Qed.

  Program Fixpoint Iterate_Decide_Comp_opt'_Pre (A : Set)
          (Remaining Visited : list A)
          (P : BoundedIndex (Visited ++ Remaining) -> option Prop)
          (Q : Prop)
          {struct Remaining }
  : Comp bool :=
    match Remaining with
      | nil => ret true
      | cons a Remaining' =>
        match (P {| bindex := a;
                    indexb := {| ibound := List.length Visited;
                                 boundi := _ |} |}) with
          | Some P' => b' <- {b' | Q -> decides b' P'};
                      If_Then_Else b'
                                   (Iterate_Decide_Comp_opt'_Pre _ Remaining' (Visited ++ [a])
                                                             (Ensemble_opt_BoundedIndex_app_comm_cons _ _ _ P) Q)
                                   (ret false)
          | None => (Iterate_Decide_Comp_opt'_Pre _ Remaining' (Visited ++ [a])
                                              (Ensemble_opt_BoundedIndex_app_comm_cons _ _ _ P) Q)
        end
    end%comp.
  Next Obligation.
    clear P; induction Visited; simpl; auto.
  Defined.

  Lemma refine_Iterate_Decide_Comp'_Pre
        {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P : BoundedIndex (Visited ++ Remaining) -> option Prop)
           (Q : Prop),
      refine (@Iterate_Decide_Comp'_Pre _ Remaining Visited
                                        (fun idx => match P idx with
                                                      | Some P' => P'
                                                      | None => True
                                                    end) Q)
             (@Iterate_Decide_Comp_opt'_Pre _ Remaining Visited P Q).
  Proof.
    induction Remaining; simpl; intros.
    - reflexivity.
    - destruct (P ``(a)).
      + f_equiv; unfold pointwise_relation; intros.
        destruct a0; simpl; try reflexivity.
        setoid_rewrite <- IHRemaining; f_equiv.
        unfold Ensemble_BoundedIndex_app_comm_cons,
        Ensemble_opt_BoundedIndex_app_comm_cons; simpl.
        destruct (app_comm_cons' a Visited Remaining); simpl.
        reflexivity.
      + rewrite decides_True_Pre; simplify with monad laws; simpl.
        setoid_rewrite <- IHRemaining; f_equiv.
        unfold Ensemble_BoundedIndex_app_comm_cons,
        Ensemble_opt_BoundedIndex_app_comm_cons; simpl.
        destruct (app_comm_cons' a Visited Remaining); simpl.
        reflexivity.
  Qed.

  Lemma refine_Iterate_Decide_Comp_Pre
  : forall (Bound : list string)
           (P : BoundedIndex Bound -> option Prop)
           (Q : Prop),
      refine (@Iterate_Decide_Comp_Pre _ (fun idx => match P idx with
                                                 | Some P' => P'
                                                 | None => True
                                               end) Q)
             (@Iterate_Decide_Comp_opt'_Pre _ Bound [] P Q).
  Proof.
    intros; unfold Iterate_Decide_Comp_Pre;
    rewrite refine_Iterate_Decide_Comp'_Pre.
    reflexivity.
    apply string_dec.
  Qed.

  Lemma refine_Iterate_Decide_Comp_equiv_Pre
        (Q Q' : Prop)
        {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P P' : Ensemble (BoundedIndex (Visited ++ Remaining))),
      (forall idx, P idx -> P' idx)
      -> (forall idx, ~ P idx -> ~ P' idx)
      -> (Q -> Q')
      -> refine (@Iterate_Decide_Comp'_Pre _ Remaining Visited P' Q)
                (@Iterate_Decide_Comp'_Pre _ Remaining Visited P Q').
  Proof.
    induction Remaining; simpl; intros.
    - reflexivity.
    - f_equiv.
      + unfold refine; intros; inversion_by computes_to_inv; subst;
        econstructor; destruct v; simpl in *; eauto.
      + unfold pointwise_relation; intros b; destruct b; simpl.
        apply IHRemaining; eauto.
        unfold Ensemble_BoundedIndex_app_comm_cons; simpl;
        destruct (app_comm_cons' a Visited Remaining); simpl; eauto.
        unfold Ensemble_BoundedIndex_app_comm_cons; simpl;
        destruct (app_comm_cons' a Visited Remaining); simpl; eauto.
        reflexivity.
  Qed.

  (* Consequences of ith_replace_BoundIndex_neq and ith_replace_BoundIndex_eq on updates *)

  Lemma refine_SatisfiesSchemaConstraints_self
  : forall qsSchema
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup tup' : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx))),
      refine {b | decides b (SatisfiesSchemaConstraints Ridx tup tup')}
             match (schemaConstraints (QSGetNRelSchema qsSchema Ridx)) with
                 Some Constr => {b | decides b (Constr tup tup') }
               | None => ret true
             end.
  Proof.
    unfold SatisfiesSchemaConstraints.
    intros; destruct (schemaConstraints (QSGetNRelSchema qsSchema Ridx));
    eauto using decides_True.
    reflexivity.
  Qed.

  Lemma refine_SatisfiesSchemaConstraints
  : forall qsSchema qs
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx))),
      refine {b | decides b
                          (forall tup',
                             GetUnConstrRelation qs Ridx tup'
                             -> SatisfiesSchemaConstraints Ridx tup tup')}
             match (schemaConstraints (QSGetNRelSchema qsSchema Ridx)) with
                 Some Constr =>
                 {b | decides b (forall tup',
                                   GetUnConstrRelation qs Ridx tup'
                                   -> Constr tup tup')}
               | None => ret true
             end.
  Proof.
    unfold SatisfiesSchemaConstraints.
    intros; destruct (schemaConstraints (QSGetNRelSchema qsSchema Ridx));
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesSchemaConstraints'
  : forall qsSchema qs
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx))),
      refine {b | decides b
                          (forall tup',
                             GetUnConstrRelation qs Ridx tup'
                             -> SatisfiesSchemaConstraints Ridx tup' tup)}
             match (schemaConstraints (QSGetNRelSchema qsSchema Ridx)) with
                 Some Constr =>
                 {b | decides b (forall tup',
                                   GetUnConstrRelation qs Ridx tup'
                                   -> Constr tup' tup)}
               | None => ret true
             end.
  Proof.
    unfold SatisfiesSchemaConstraints.
    intros; destruct (schemaConstraints (QSGetNRelSchema qsSchema Ridx));
    eauto using decides_True.
    reflexivity.
    apply decides_2_True.
  Qed.

  Lemma refine_SatisfiesCrossConstraints
  : forall qsSchema qs
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx))),
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                                 SatisfiesCrossRelationConstraints
                                   Ridx Ridx' tup
                                   (GetUnConstrRelation qs Ridx')))
        (@Iterate_Decide_Comp_opt' _ _ []
                                   (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                        | Some CrossConstr =>
                                          Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                        | None => None
                                      end)) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma refine_Iterate_Decide_Comp_equiv
        {A : Set}
        (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'})
  : forall (Remaining Visited : list A)
           (P P' : Ensemble (BoundedIndex (Visited ++ Remaining))),
      (forall idx, P idx -> P' idx) ->
      (forall idx, ~ P idx -> ~ P' idx) ->
      refine (@Iterate_Decide_Comp' _ Remaining Visited P')
             (@Iterate_Decide_Comp' _ Remaining Visited P).
  Proof.
    induction Remaining; simpl; intros.
    - reflexivity.
    - f_equiv.
      + unfold refine; intros; inversion_by computes_to_inv; subst;
        econstructor; destruct v; simpl in *; eauto.
      + unfold pointwise_relation; intros b; destruct b; simpl.
        apply IHRemaining.
        unfold Ensemble_BoundedIndex_app_comm_cons; simpl;
        destruct (app_comm_cons' a Visited Remaining); simpl; eauto.
        unfold Ensemble_BoundedIndex_app_comm_cons; simpl;
        destruct (app_comm_cons' a Visited Remaining); simpl; eauto.
        reflexivity.
  Qed.

  Lemma refine_SatisfiesCrossConstraints_Pre (Q : Prop)
  : forall qsSchema qs
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx))),
      refine
        (@Iterate_Decide_Comp_Pre _
                              (fun Ridx' =>
                                 SatisfiesCrossRelationConstraints
                                   Ridx Ridx' tup
                                   (GetUnConstrRelation qs Ridx')) Q)
        (@Iterate_Decide_Comp_opt'_Pre _ _ []
                                   (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                        | Some CrossConstr =>
                                          Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                        | None => None
                                      end) Q) .
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp_Pre.
    unfold SatisfiesCrossRelationConstraints; f_equiv.
    apply functional_extensionality; intros.
    destruct BuildQueryStructureConstraints; reflexivity.
  Qed.

  Lemma DeletePrimaryKeysOK {qsSchema}
  : forall (qs : UnConstrQueryStructure qsSchema)
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           DeletedTuples
           attrlist1 attrlist2,
      refine {b | (forall tup tup',
                          GetUnConstrRelation qs Ridx tup
                          -> GetUnConstrRelation qs Ridx tup'
                          -> (FunctionalDependency_P attrlist1 attrlist2 tup tup'))
                     -> decides b (DeletePreservesSchemaConstraints
                                      (GetUnConstrRelation qs Ridx)
                                      DeletedTuples
                                      (FunctionalDependency_P attrlist1 attrlist2))}
             (ret true).
  Proof.
    unfold DeletePreservesSchemaConstraints, FunctionalDependency_P;
    intros * v Comp_v; inversion_by computes_to_inv; subst.
    constructor; simpl.
    intros.
    unfold EnsembleDelete in *; destruct H0; destruct H1; eauto.
  Qed.

  Local Transparent Count.

  Lemma refine_Where' {A B} :
    forall (P : Ensemble A)
           (P_dec : DecideableEnsemble P)
           (bod : Comp (list B)),
    forall a,
      refine
             (if (dec a) then
                bod
              else
                (ret []))
             (Where (P a) bod)%QuerySpec.
  Proof.
    unfold refine, Query_Where; intros.
    inversion_by computes_to_inv.
    caseEq (dec a).
    apply dec_decides_P in H; eauto.
    rewrite H1; eauto.
    unfold not; intros H'; apply dec_decides_P in H'; congruence.
  Qed.

  Require Import flattenCompListProperties.

  Lemma In_UnConstrQuery_In {qsSchema} {A}
  : forall (qs : UnConstrQueryStructure qsSchema) Ridx bod results,
      UnConstrQuery_In qs Ridx bod ↝ results
      -> forall (a : A), List.In a results ->
                         exists (tup' : IndexedTuple) results',
                           Ensembles.In _ (GetUnConstrRelation qs Ridx) tup'
                           /\ bod tup' ↝ results'
                           /\ List.In a results'.
  Proof.
    unfold UnConstrQuery_In, QueryResultComp; intros;
    inversion_by computes_to_inv.
    unfold EnsembleListEquivalence in *; intuition.
    rewrite map_map in H2.
    remember (GetUnConstrRelation qs Ridx); clear Hequ;
    revert u a results H0 H2 H H3;
    induction x; simpl in *; intros;
    inversion_by computes_to_inv; subst.
    simpl in H0; intuition.
    apply in_app_or in H0; intuition.
    exists a x0; intuition; eapply H3; eauto.
    inversion H; subst.
    destruct (IHx (fun tup => tup <> a /\ u tup) _ _ H1 H4 H7).
    unfold Ensembles.In; intros; intuition; subst; eauto.
    eapply H3 in H8; intuition.
    intuition.
    apply H3; intuition.
    destruct_ex; intuition.
    exists x2 x3; intuition.
    apply H5.
  Qed.

  Lemma In_UnConstrQuery_In' {qsSchema} {A}
  : forall (qs : UnConstrQueryStructure qsSchema) Ridx
           (bod : Tuple -> Comp (list A))
           results
           (a : A) (tup' : IndexedTuple),
      Ensembles.In _ (GetUnConstrRelation qs Ridx) tup'
      -> (forall results', bod tup' ↝ results'
                           -> List.In a results')
      -> UnConstrQuery_In qs Ridx bod ↝ results
      -> List.In a results.
  Proof.
    unfold UnConstrQuery_In, QueryResultComp, Ensembles.In; intros.
    inversion_by computes_to_inv.
    unfold EnsembleListEquivalence in *; intuition.
    rewrite map_map in H3.
    remember (GetUnConstrRelation qs Ridx); clear Hequ;
    revert u a results H H0 H1 H3 H4;
    induction x; simpl in *; intros;
    inversion_by computes_to_inv; subst.
    simpl in *; intuition; eapply H4; eauto.
    apply H4 in H; intuition; subst; apply in_or_app; eauto.
    right; inversion H1; subst.
    eapply (IHx (fun tup => tup <> a /\ u tup)); eauto.
    intuition; subst; eauto.
    apply H4; eauto.
    unfold Ensembles.In; intuition; intros; eauto.
    rewrite H4 in H9; intuition.
    subst; eauto.
    apply H4; eauto.
  Qed.

  Lemma DeleteForeignKeysCheck {qsSchema}
  : forall (qs : UnConstrQueryStructure qsSchema)
           (Ridx Ridx' : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (DeletedTuples : Ensemble (@Tuple (schemaHeading (QSGetNRelSchema _ Ridx))))
           (Delete_dec : DecideableEnsemble DeletedTuples)
           (attr : Attributes (schemaHeading (QSGetNRelSchema _ Ridx)))
           (attr' : Attributes (schemaHeading (QSGetNRelSchema _ Ridx')))
           (tupmap : Domain (schemaHeading (QSGetNRelSchema _ Ridx)) attr
                     -> Domain (schemaHeading (QSGetNRelSchema _ Ridx')) attr')
           (AgreeDelete : forall tup tup',
                            tupleAgree tup tup' [attr] ->
                            DeletedTuples tup ->
                            DeletedTuples tup')
           (attr_eq_dec : Query_eq (Domain (schemaHeading (QSGetNRelSchema _ Ridx)) attr))
                      (P : Prop)
           (ForeignKey_P_P :
              P -> (forall tup' : IndexedTuple,
                        GetUnConstrRelation qs Ridx' tup' ->
                        ForeignKey_P attr' attr tupmap tup'
                                     (GetUnConstrRelation qs Ridx)))

           (tup_map_inj : forall a a', tupmap a = tupmap a' -> a = a'),
      refine {b' |
              P ->
               decides b'
                       (DeletePreservesCrossConstraints
                       (GetUnConstrRelation qs Ridx)
                       (GetUnConstrRelation qs Ridx')
                       DeletedTuples
                       (ForeignKey_P attr' attr tupmap))}
             (x <- Count (For (UnConstrQuery_In
                                 qs Ridx'
                                 (fun tup' =>
                                    UnConstrQuery_In
                                      qs Ridx
                                      (fun tup =>
                                         Where (DeletedTuples tup)
                                         Where (tupmap (tup attr) = tup' attr')
                                         Return ()))));
              ret (match x with
                       0  => true
                     | S _ => false
                   end)).
  Proof.
    simpl; unfold ForeignKey_P; intros.
    intros v Comp_v.
    apply computes_to_inv in Comp_v; destruct_ex; split_and.
    unfold Count in *; inversion_by computes_to_inv.
    destruct x0; simpl in *; subst; inversion_by computes_to_inv; subst;
    constructor; simpl; unfold not;
    unfold DeletePreservesCrossConstraints; intros.
    - destruct (ForeignKey_P_P H _ H1) as [tup2 [In_tup2 Agree_tup2]].
      eexists; intuition eauto.
      unfold EnsembleDelete; constructor; unfold In; intros; eauto.
      unfold Complement, Ensembles.In, not; intros.
      unfold Query_For in *; inversion_by computes_to_inv.
      rewrite Permutation_nil in H4; symmetry in H5; eauto.
      apply (fun x => In_UnConstrQuery_In' _ _ _ _ () _ H1 x H4).
      intros; apply (fun x => In_UnConstrQuery_In' _ _ _ _ () _ In_tup2 x H0).
      intros.
      unfold Query_Where in H5; apply computes_to_inv in H6;
      simpl in *; intuition.
      apply computes_to_inv in H6; split_and.
      rewrite Agree_tup2 in H9; pose proof (H9 (refl_equal _)) as H';
      apply computes_to_inv in H'; simpl in *; subst; simpl; eauto.
    - unfold Query_For in *; inversion_by computes_to_inv.
      eapply In_UnConstrQuery_In with (a := u) in H2; destruct_ex;
      intuition.
      pose proof (H4 _ H2); pose proof (H1 _ H2); destruct_ex;
      intuition.
      eapply In_UnConstrQuery_In with (a := u) in H0; destruct_ex;
      intuition.
      unfold EnsembleDelete in *; inversion H6; subst;
      unfold Ensembles.In, Complement, In in *.
      unfold Query_Where in H0; apply computes_to_inv in H0;
      intuition.
      case_eq (@dec _ _ Delete_dec x5); intros.
      + apply Delete_dec in H0; pose proof (H14 H0) as H'.
        apply computes_to_inv in H'; split_and.
        rewrite H10 in *.
        destruct (A_eq_dec (indexedTuple x5 attr) (indexedTuple x3 attr)).
        * rewrite e in *;
          pose proof (H16 (refl_equal _)) as e'; apply computes_to_inv in e'; simpl in *; subst.
          apply H13; eapply AgreeDelete; eauto.
          unfold tupleAgree; simpl; intros attr'' In_attr''; destruct In_attr'';
          [rewrite H18 in *; eauto | intuition ].
        * rewrite H17 in H12; simpl in *; eauto.
      + rewrite H15 in H12; simpl in *; eauto.
        intros H'; apply dec_decides_P in H'; congruence.
      + eapply Permutation_in; symmetry in H3; simpl; eauto.
        simpl; eauto.
  Qed.

End ConstraintCheckRefinements.

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

  exfalso; intuition.

  inversion_by computes_to_inv.

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

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

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

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

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

  destruct H0.

  - subst x; split; [ | exists head'; split; [ apply H3  | ] ]; auto.
  - pose proof (EnsembleListEquivalence_slice _ _ _ H3) as smaller_equiv.
    pose proof (flatten_CompList_app _ _ _ _ before after) as flatten_app.
    set (smaller_ens := (fun x : IndexedTuple => ens x /\ ~ In x x1_middle)).
    split.

    + eapply H1; try assumption.
      econstructor; [ | constructor; symmetry; eassumption ].
      econstructor.
      constructor.

      apply smaller_equiv.

      unfold boxed_option in *.
      rewrite !map_app, !map_map.
      apply flatten_app.
    + assert (exists x0 : IndexedTuple, smaller_ens x0 /\ indexedTuple x0 = x) as temp.
      apply H2; try eassumption.
      econstructor; [ | constructor; symmetry; eassumption ].
      econstructor.
      constructor.

      eassumption.
      unfold boxed_option in *.
      rewrite !map_app, !map_map.
      apply flatten_app.

      destruct temp as [ x0 ( ens_x & _eq ) ]; subst.
      eexists; split; eauto.

      unfold smaller_ens in ens_x; intuition.
Qed.

Lemma For_computes_to_nil :
  forall {heading} P,
  forall ens,
    computes_to (For (QueryResultComp (heading := heading) ens
                                      (fun tup => Where (P tup) Return tup))) [] ->
    forall x,
      ens x -> ~ (P (indexedTuple x)).
Proof.
  unfold refine, decides, Count, Query_For, QueryResultComp; intros **.

                                            inversion_by computes_to_inv.
  symmetry in H2; apply Permutation_nil in H2; subst.
  apply H1 in H0.
  apply in_split in H0.
  destruct H0 as [ x1_before [ x1_after _eq ] ]; subst.

  rewrite map_map in H3.
  eapply flatten_CompList_nil; unfold boxed_option; eauto; intuition.
Qed.

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

Lemma refine_constraint_check_into_query :
  forall {schm tbl} P (P_dec : DecideableEnsemble P),
  forall (c : UnConstrQueryStructure schm),
    refine
      (Pick (fun (b : bool) =>
               decides b
                       (exists tup2: @IndexedTuple _,
                          (GetUnConstrRelation c tbl tup2 /\ P (indexedTuple tup2)))))
      (Bind
         (Count (For (UnConstrQuery_In c tbl (fun tup => Where (P tup) Return tup))))
         (fun count => ret (negb (beq_nat count 0)))).
Proof.
  unfold refine, Count, UnConstrQuery_In; intros * excl * pick_comp ** .
  inversion_by computes_to_inv; subst.

  constructor.

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

  pose proof (For_computes_to_nil _ (GetUnConstrRelation c tbl) H0).
  rewrite not_exists_forall; intro a; rewrite not_and_implication; intros.
  apply H; trivial.

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

  apply decidable_excl; assumption.
Qed.

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

Require Import tupleAgree Bool AdditionalRefinementLemmas.

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

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

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

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

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

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

Ltac simplify_trivial_SatisfiesSchemaConstraints :=
  simpl;
  try rewrite refine_tupleAgree_refl_True;
  try setoid_rewrite decides_True;
  try setoid_rewrite decides_2_True; reflexivity.

Ltac simplify_trivial_SatisfiesCrossRelationConstraints :=
  simpl map; simpl;
    repeat match goal with
             | |- context [if _ then ret true else ret false] =>
               setoid_rewrite refine_if_bool_eta at 1
             | |- refine (Bind (Pick (fun b => decides b True)) _) _ =>
             etransitivity; [ apply refine_bind;
                              [ apply decides_True
                              | unfold pointwise_relation;
                                intro; higher_order_1_reflexivity ]
                            | rewrite refineEquiv_bind_unit at 1;
                              unfold If_Then_Else ]
             | |- refine (Bind (Pick (fun b' => decides b' (forall _ _ _, True))) _ ) _ =>
               etransitivity;
                 [ apply refine_bind;
                   [ apply decides_3_True
                   | unfold pointwise_relation;
                     intro; higher_order_1_reflexivity ]
                 | rewrite refineEquiv_bind_unit at 1;
                   unfold If_Then_Else ]

    end.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Permutation.v

    Definition and properties of permutations

    Definition: permutation

                                    Laurent.Thery@inria.fr (2006)
 **********************************************************************)
Require Export List.
Require Export ListAux.
From Coq Require Export Permutation.

Section permutation.
Variable A : Set.

Hint Constructors Permutation : core.

(**************************************
 A transposition is a permutation
 **************************************)

Theorem perm_transposition :
  forall a b (l1 l2 l3 : list A),
    Permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3).
Proof.
  intros a b l1 l2 l3.
  apply Permutation_app; auto.
  change
    (Permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3)
                 ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *.
  repeat rewrite <- app_ass.
  apply Permutation_app; auto.
  apply perm_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto.
  apply Permutation_app_comm; auto.
  repeat rewrite app_ass.
  apply Permutation_app; auto.
  apply Permutation_app_comm; auto.
Qed.

(**************************************
 An element of a list can be put on top of the list to get a permutation
 **************************************)

Theorem in_permutation_ex :
  forall a l, In a l -> exists l1 : list A, Permutation (a :: l1) l.
Proof.
  intros a l; elim l; simpl in |- *; auto.
  intros H; case H; auto.
  intros a0 l0 H [H0| H0].
  exists l0; rewrite H0; auto.
  case H; auto; intros l1 Hl1; exists (a0 :: l1).
  apply perm_trans with (a0 :: a :: l1); auto.
Qed.

(**************************************
 Take a list and return tle list of all pairs of an element of the
 list and the remaining list
 **************************************)

Fixpoint split_one (l : list A) : list (A * list A) :=
  match l with
  | nil => nil (A:=A * list A)
  | a :: l1 =>
    (a, l1)
      :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1)
  end.

(**************************************
 The pairs of the list are a permutation
 **************************************)

Theorem split_one_permutation :
  forall (a : A) (l1 l2 : list A),
    In (a, l1) (split_one l2) -> Permutation (a :: l1) l2.
Proof.
  intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto.
  intros a l1 H1; case H1.
  intros a l H a0 l1 [H0| H0].
  injection H0; intros H1 H2; rewrite H2, H1; auto.
  generalize H H0; elim (split_one l); simpl in |- *; auto.
  intros H1 H2; case H2.
  intros a1 l0 H1 H2 [H3| H3]; auto.
  injection H3; intros H4 H5; (rewrite <- H4, <- H5).
  apply perm_trans with (a :: fst a1 :: snd a1); auto.
  apply perm_skip.
  apply H2; auto.
  case a1; simpl in |- *; auto.
Qed.

(**************************************
 All elements of the list are there
 **************************************)

Theorem split_one_in_ex :
  forall (a : A) (l1 : list A),
    In a l1 -> exists l2 : list A, In (a, l2) (split_one l1).
Proof.
  intros a l1; elim l1; simpl in |- *; auto.
  intros H; case H.
  intros a0 l H [H0| H0]; auto.
  exists l; left; f_equal; auto.
  case H; auto.
  intros x H1; exists (a0 :: x); right; auto.
  apply
    (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x));
    auto.
Qed.

(**************************************
 An auxiliary function to generate all permutations
 **************************************)

Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} :
  list (list A) :=
  match n with
  | O => nil :: nil
  | S n1 =>
    flat_map
      (fun p : A * list A =>
         map (cons (fst p)) (all_permutations_aux (snd p) n1)) (
        split_one l)
  end.
(**************************************
 Generate all the permutations
 **************************************)

Definition all_permutations (l : list A) := all_permutations_aux l (length l).

(**************************************
 All the elements of the list are permutations
 **************************************)

Lemma all_permutations_aux_permutation :
  forall (n : nat) (l1 l2 : list A),
    n = length l2 -> In l1 (all_permutations_aux l2 n) -> Permutation l1 l2.
Proof.
  intros n; elim n; simpl in |- *; auto.
  intros l1 l2; case l2.
  simpl in |- *; intros H0 [H1| H1].
  rewrite <- H1; auto.
  case H1.
  simpl in |- *; intros; discriminate.
  intros n0 H l1 l2 H0 H1.
  case in_flat_map_ex with (1 := H1).
  clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2).
  case in_map_inv with (1 := H2).
  simpl in |- *; intros y (H3, H4).
  rewrite H4; auto.
  apply perm_trans with (a1 :: l3); auto.
  apply perm_skip; auto.
  apply H with (2 := H3).
  apply eq_add_S.
  apply trans_equal with (1 := H0).
  change (length l2 = length (a1 :: l3)) in |- *.
  apply Permutation_length; auto.
  apply Permutation_sym; apply split_one_permutation; auto.
  apply split_one_permutation; auto.
Qed.

Theorem all_permutations_permutation :
  forall l1 l2 : list A, In l1 (all_permutations l2) -> Permutation l1 l2.
Proof.
  intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2);
    auto.
Qed.

(**************************************
 A permutation is in the list
 **************************************)

Lemma permutation_all_permutations_aux :
  forall (n : nat) (l1 l2 : list A),
    n = length l2 -> Permutation l1 l2 -> In l1 (all_permutations_aux l2 n).
Proof.
  intros n; elim n; simpl in |- *; auto.
  intros l1 l2; case l2.
  intros H H0; rewrite (Permutation_nil (Permutation_sym H0)); auto with datatypes.
  simpl in |- *; intros; discriminate.
  intros n0 H l1; case l1.
  intros l2 H0 H1;
    rewrite (Permutation_nil H1) in H0;
    discriminate.
  clear l1; intros a1 l1 l2 H1 H2.
  case (split_one_in_ex a1 l2); auto.
  apply Permutation_in with (1 := H2); auto with datatypes.
  intros x H0.
  apply in_flat_map with (b := (a1, x)); auto.
  apply in_map; simpl in |- *.
  apply H; auto.
  apply eq_add_S.
  apply trans_equal with (1 := H1).
  change (length l2 = length (a1 :: x)) in |- *.
  apply Permutation_length; auto.
  apply Permutation_sym; apply split_one_permutation; auto.
  apply Permutation_cons_inv with (a := a1).
  apply perm_trans with (1 := H2).
  apply Permutation_sym; apply split_one_permutation; auto.
Qed.

Theorem permutation_all_permutations :
  forall l1 l2 : list A, Permutation l1 l2 -> In l1 (all_permutations l2).
Proof.
  intros l1 l2 H; unfold all_permutations in |- *;
    apply permutation_all_permutations_aux; auto.
Qed.

(**************************************
 Permutation is decidable
 **************************************)

Definition permutation_dec :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {Permutation l1 l2} + {~ Permutation l1 l2}.
  intros H l1 l2.
  case (In_dec (list_eq_dec H) l1 (all_permutations l2)).
  intros i; left; apply all_permutations_permutation; auto.
  intros i; right; contradict i; apply permutation_all_permutations; auto.
Defined.

(* A more efficient version *)
Definition permutation_dec1 :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {Permutation l1 l2} + {~ Permutation l1 l2}.
intros dec; fix perm 1; intros l1; case l1.
intros l2; case l2.
left; auto.
intros a l3; right; intros H; generalize (Permutation_length H);
 discriminate.
intros a l3 l2.
case (In_dec1 dec a l2); intros H1.
case H1.
intros x; case x; simpl.
intros l4 l5 Hl4l5.
case (perm l3 (l4 ++ l5)); intros H2.
left; subst.
apply perm_trans with ((a::l5) ++ l4); auto.
simpl; apply perm_skip; auto.
apply perm_trans with (1 := H2); auto.
apply Permutation_app_comm.
apply Permutation_app_comm.
right; contradict H2.
apply Permutation_cons_inv with a.
apply perm_trans with (1 := H2).
rewrite Hl4l5.
apply perm_trans with ((a::l5) ++ l4); auto.
apply Permutation_app_comm.
simpl; apply perm_skip; auto.
apply Permutation_app_comm.
right; contradict H1.
apply Permutation_in with (1 := H1); auto with datatypes.
Defined.

End permutation.

(**************************************
   Hints
 **************************************)

Global Hint Resolve Permutation_app : core.
Global Hint Resolve Permutation_app_comm : core.

(**************************************
   Implicits
 **************************************)

Arguments permutation_dec1 [A].

(**************************************
  Permutation  of a map can be inverted
 *************************************)

Lemma Permutation_map_ex_aux :
  forall (A B : Set) (f : A -> B) l1 l2 l3,
    Permutation l1 l2 ->
    l1 = map f l3 -> exists l4, Permutation l4 l3 /\ l2 = map f l4.
Proof.
  intros A B f l1 l2 l3 H H0.
  assert (exists l4 : list A, l2 = map f l4 /\ Permutation l4 l3).
  {
    rewrite H0 in H.
    apply Permutation_sym in H.
    epose proof (Permutation_map_inv f _ H).
    destruct H1; auto.
    now exists x.
  }
  destruct H1.
  now exists x.
Qed.

Theorem Permutation_map_ex :
  forall (A B : Set) (f : A -> B) l1 l2,
    Permutation (map f l1) l2 ->
    exists l3, Permutation l3 l1 /\ l2 = map f l3.
Proof.
  intros A0 B f l1 l2 H; apply Permutation_map_ex_aux with (l1 := map f l1);
    auto.
Qed.

(**************************************
   Permutation is compatible with flat_map
 **************************************)

Theorem permutation_flat_map :
  forall (A B : Set) (f : A -> list B) l1 l2,
    Permutation l1 l2 -> Permutation (flat_map f l1) (flat_map f l2).
Proof.
  intros A B f l1 l2 H; elim H; simpl in |- *; auto.
  intros a b l; auto.
  repeat rewrite <- app_ass.
  apply Permutation_app; auto.
  intros k3 l4 l5 H0 H1 H2 H3; apply perm_trans with (1 := H1); auto.
Qed.


Lemma top_winning_strategy {p} {s : strategy top p}
 : winning_strategy s <-> p = player_P.
Proof.
  unfold winning_strategy.
  setoid_rewrite top_play_won_by.
  firstorder.
  eapply H.
  apply top_player_follows_strategy.
  Unshelve.
  exact trivial_play.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a}(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive color  :=
  | Blue : color
  | White : color
  | Red : color .
Axiom color_WhyType : WhyType color.
Existing Instance color_WhyType.

(* Why3 assumption *)
Definition monochrome(a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color): Prop :=
  forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) -> ((map.Map.get a k) = c).

Parameter nb_occ: (map.Map.map Z color) -> Z -> Z -> color -> Z.

Axiom nb_occ_null : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  (j <= i)%Z -> ((nb_occ a i j c) = 0%Z).

Axiom nb_occ_add_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  ((i < j)%Z /\ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a i j
  c) = ((nb_occ a i (j - 1%Z)%Z c) + 1%Z)%Z).

Axiom nb_occ_add_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (c:color), ((i < j)%Z /\ ~ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a
  i j c) = (nb_occ a i (j - 1%Z)%Z c)).

Axiom nb_occ_split : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ a i k c) = ((nb_occ a i j
  c) + (nb_occ a j k c))%Z).

Axiom nb_occ_store_outside_up : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (k:Z) (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ (map.Map.set a k c)
  i j c) = (nb_occ a i j c)).

Axiom nb_occ_store_outside_down : forall (a:(map.Map.map Z color)) (i:Z)
  (j:Z) (k:Z) (c:color), ((k < i)%Z /\ (i <= j)%Z) -> ((nb_occ (map.Map.set a
  k c) i j c) = (nb_occ a i j c)).

Axiom nb_occ_store_eq_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= k)%Z /\ (k < j)%Z) -> (((map.Map.get a k) = c) ->
  ((nb_occ (map.Map.set a k c) i j c) = (nb_occ a i j c))).

Open Scope Z_scope.
Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.95.2," timelimit 15.

(* Why3 goal *)
Theorem nb_occ_store_eq_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (k:Z) (c:color), ((i <= k)%Z /\ (k < j)%Z) -> ((~ ((map.Map.get a
  k) = c)) -> ((nb_occ (map.Map.set a k c) i j c) = ((nb_occ a i j
  c) + 1%Z)%Z)).
intros a i j k c (Hik & Hkj) H.
rewrite nb_occ_split with (j:=k); auto with zarith.
rewrite nb_occ_store_outside_up; auto with zarith.
rewrite nb_occ_split with (i:=k) (j:=k+1); auto with zarith.
rewrite nb_occ_split with (i:=i) (j:=k) (k:=j); auto with zarith.
rewrite nb_occ_split with (i:=k) (j:=k+1) (k:=j); auto with zarith.
rewrite nb_occ_store_outside_down with (i:=k+1); auto with zarith.
ae.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Inductive TwoObj : Type := TwoX | TwoY.

Inductive TwoHom : TwoObj -> TwoObj -> Type :=
| TwoIdX : TwoHom TwoX TwoX
| TwoIdY : TwoHom TwoY TwoY
| TwoXY  : TwoHom TwoX TwoY.

Definition TwoHom_inv_t : forall x y, TwoHom x y -> Prop.
Proof. hammer_hook "Two" "Two.TwoHom_inv_t".
intros [] [] f.
exact (f = TwoIdX).
exact (f = TwoXY).
exact False.
exact (f = TwoIdY).
Defined.

Corollary TwoHom_inv x y f : TwoHom_inv_t x y f.
Proof. hammer_hook "Two" "Two.TwoHom_inv". destruct f; reflexivity. Qed.

Lemma TwoHom_Y_X_absurd : TwoHom TwoY TwoX -> False.
Proof. hammer_hook "Two" "Two.TwoHom_Y_X_absurd". inversion 1. Qed.

Hint Extern 4 => contradiction TwoHom_Y_X_absurd : two_laws.

Program Definition _2 : Category := {|
obj     := TwoObj;
hom     := TwoHom;
homset  := Morphism_equality;
id      := fun x => match x with
| TwoX => TwoIdX
| TwoY => TwoIdY
end;
compose := fun x y z (f : TwoHom y z) (g : TwoHom x y) =>
match x, y, z with
| TwoX, TwoX, TwoX => TwoIdX
| TwoY, TwoY, TwoY => TwoIdY
| TwoX, TwoX, TwoY => TwoXY
| TwoX, TwoY, TwoY => TwoXY
| _,    _,    _    => _
end
|}.
Next Obligation. destruct x, y, z; intuition. Qed.
Next Obligation.
destruct x, y, z; auto with two_laws;
intuition; discriminate.
Qed.
Next Obligation.
destruct x, y, z; auto with two_laws;
intuition; discriminate.
Qed.
Next Obligation.
destruct x, y, z; auto with two_laws;
intuition; discriminate.
Qed.
Next Obligation. destruct f; auto. Qed.
Next Obligation. destruct f; auto. Qed.
Next Obligation. destruct x, y, z, w; auto with two_laws; intuition. Qed.
Next Obligation. destruct x, y, z, w; auto with two_laws; intuition. Qed.

Require Import Category.Instance.Sets.

Program Definition _2_as_Set : _2 ⟶ Sets := {|
fobj := fun x =>
match x with
| TwoX => {| carrier := False |}
| TwoY => {| carrier := True |}
end;
fmap := fun x y f =>
match x, y with
| TwoY, TwoY => _
| _, _       => _
end
|}.
Next Obligation.
construct.
- repeat intro.
contradiction.
- equivalence.
Defined.
Next Obligation.
construct.
- repeat intro.
exact True.
- equivalence.
Defined.
Next Obligation.
construct; auto.
Defined.
Next Obligation.
construct; auto.
destruct x, y; simpl in *; auto with two_laws.
proper.
destruct x, y; simpl in *; auto with two_laws.
Qed.
Next Obligation.
destruct x; simpl in *; auto with two_laws.
contradiction.
Qed.
Next Obligation.
destruct x, y, z; simpl in *; auto with two_laws.
contradiction.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  rat.v                                                                   *)
(*                                                                          *)
(*  Summary of rational arithmetic                                          *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                rat.v                                     *)
(****************************************************************************)

Require Import quotient.
Require Import subset.
Require Import intnumbers.
Require Export rational_defs.
Require Export PlusQ.
Require Export MultQ.
Require Import AC.
Require Import HS.

Section rat.

(*******************************************************************
PROPERTIES OF Q
********************************************************************

plusQ_sym     : (n,m:Q)                       n + m = m + n
plusQ_assoc_l : (n,m,p:Q)              n + (m + p) = (n + m) + p
plusQ_permute : (n,m,p:Q)              n + (m + p) = m + (n + p)
plusQ_assoc_r : (n,m,p:Q)              (n + m) + p = n + (m + p)
plusQ_plus_l  : (n,m,p:Q)               n + m = n + p =>  m = p

multQ_sym         : (n,m:Q)                   n*m = m*n
multQ_assoc_l     : (n,m,p:Q)             n*(m*p) = (n*m)*p
multQ_permute     : (n,m,p:Q)             n*(m*p) = m*(n*p)
multQ_assoc_r     : (n,m,p:Q)             (n*m)*p = n*(m*p)

distribQ_l : (n,m,p:Q)           (n + m)*p = (n*p) + (m*p)
distribQ   : (n,m,p:Q)           p*(n + m) = (p*n) + (p*m).

*********************************************************************)

(* Tactiques de d'ecision AC pour l'addition sur Q.*)

Open Scope RAT_scope.

Lemma plusQ_simpl_l : forall n m p : Q, m = p -> n + m = n + p.
intros. elim H. auto. Qed.

Lemma multQ_simpl_l : forall n m p : Q, m = p -> n * m = n * p.
intros. elim H. auto. Qed.

End rat.

Ltac CQa := intros; ac_of eq plusQ plusQ_sym plusQ_permute; auto.

Ltac AQa := intros; repeat elim plusQ_assoc_l.

Ltac ACQa :=
  intros; repeat elim plusQ_assoc_l; ac_of eq plusQ plusQ_sym plusQ_permute;
   auto.

Ltac HSQa := intros; hs_of eq plusQ plusQ_sym plusQ_permute plusQ_simpl_l.

(* Tactiques de d'ecision AC pour la multiplication sur Z.*)

Ltac CQm := intros; ac_of eq multQ multQ_sym multQ_permute; auto.

Ltac AQm := intros; repeat elim multQ_assoc_l.

Ltac ACQm :=
  intros; repeat elim multQ_assoc_l; ac_of eq multQ multQ_sym multQ_permute;
   auto.

Ltac HSQm := intros; hs_of eq multQ multQ_sym multQ_permute multQ_simpl_l.


From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.heap_lang Require Import proofmode notation atomic_heap par.
From iris Require Import options.

(** Show that implementing fetch-and-add on top of CAS preserves logical
atomicity. *)

(** First: logically atomic increment directly on top of the physical heap. *)

Section increment_physical.
  Context `{!heapG Σ}.

  Definition incr_phy : val :=
    rec: "incr" "l" :=
       let: "oldv" := !"l" in
       if: CAS "l" "oldv" ("oldv" + #1)
         then "oldv" (* return old value if success *)
         else "incr" "l".

  Lemma incr_phy_spec (l: loc) :
    ⊢ <<< ∀ (v : Z), l ↦ #v >>> incr_phy #l @ ⊤ <<< l ↦ #(v + 1), RET #v >>>.
  Proof.
    iIntros (Φ) "AU". iLöb as "IH". wp_lam.
    wp_bind (!_)%E. iMod "AU" as (v) "[Hl [Hclose _]]".
    wp_load. iMod ("Hclose" with "Hl") as "AU". iModIntro.
    wp_pures. wp_bind (CmpXchg _ _ _)%E. iMod "AU" as (w) "[Hl Hclose]".
    destruct (decide (#v = #w)) as [[= ->]|Hx].
    - wp_cmpxchg_suc. iDestruct "Hclose" as "[_ Hclose]". iMod ("Hclose" with "Hl") as "HΦ".
      iModIntro. wp_pures. done.
    - wp_cmpxchg_fail. iDestruct "Hclose" as "[Hclose _]". iMod ("Hclose" with "Hl") as "AU".
      iModIntro. wp_pures. iApply "IH". done.
  Qed.
End increment_physical.

(** Next: logically atomic increment on top of an arbitrary logically atomic heap *)

Section increment.
  Context `{!heapG Σ} {aheap: atomic_heap Σ}.

  Import atomic_heap.notation.

  Definition incr : val :=
    rec: "incr" "l" :=
       let: "oldv" := !"l" in
       if: CAS "l" "oldv" ("oldv" + #1)
         then "oldv" (* return old value if success *)
         else "incr" "l".

  (** A proof of the incr specification that unfolds the definition
      of atomic accessors.  Useful for introducing them as a concept,
      but see below for a shorter proof. *)
  Lemma incr_spec_direct (l: loc) :
    ⊢ <<< ∀ (v : Z), l ↦ #v >>> incr #l @ ⊤ <<< l ↦ #(v + 1), RET #v >>>.
  Proof.
    iIntros (Φ) "AU". iLöb as "IH". wp_lam.
    awp_apply load_spec.
    (* Prove the atomic update for load *)
    rewrite /atomic_acc /=. iMod "AU" as (v) "[Hl [Hclose _]]".
    iModIntro. iExists _, _. iFrame "Hl". iSplit.
    { (* abort case *) done. }
    iIntros "Hl". iMod ("Hclose" with "Hl") as "AU". iModIntro.
    (* Now go on *)
    awp_apply cas_spec; first done.
    (* Prove the atomic update for CAS *)
    rewrite /atomic_acc /=. iMod "AU" as (w) "[Hl Hclose]".
    iModIntro. iExists _. iFrame "Hl". iSplit.
    { (* abort case *) iDestruct "Hclose" as "[? _]". done. }
    iIntros "Hl". simpl. destruct (decide (#w = #v)) as [[= ->]|Hx].
    - iDestruct "Hclose" as "[_ Hclose]". iMod ("Hclose" with "Hl") as "HΦ".
      iIntros "!>". wp_if. by iApply "HΦ".
    - iDestruct "Hclose" as "[Hclose _]". iMod ("Hclose" with "Hl") as "AU".
      iIntros "!>". wp_if. iApply "IH". done.
  Qed.

  (** A proof of the incr specification that uses lemmas to avoid reasining
      with the definition of atomic accessors. *)
  Lemma incr_spec (l: loc) :
    ⊢ <<< ∀ (v : Z), l ↦ #v >>> incr #l @ ⊤ <<< l ↦ #(v + 1), RET #v >>>.
  Proof.
    iIntros (Φ) "AU". iLöb as "IH". wp_lam.
    awp_apply load_spec.
    (* Prove the atomic update for load *)
    iApply (aacc_aupd_abort with "AU"); first done.
    iIntros (x) "H↦". iAaccIntro with "H↦"; first by eauto with iFrame.
    iIntros "$ !> AU !>".
    (* Now go on *)
    awp_apply cas_spec; first done.
    (* Prove the atomic update for CAS *)
    iApply (aacc_aupd with "AU"); first done.
    iIntros (x') "H↦". iAaccIntro with "H↦"; first by eauto with iFrame.
    iIntros "H↦ !>".
    simpl. destruct (decide (#x' = #x)) as [[= ->]|Hx].
    - iRight. iFrame. iIntros "HΦ !>".
      wp_if. by iApply "HΦ".
    - iLeft. iFrame. iIntros "AU !>".
      wp_if. iApply "IH". done.
  Qed.

  (** A "weak increment": assumes that there is no race *)
  Definition weak_incr: val :=
    rec: "weak_incr" "l" :=
       let: "oldv" := !"l" in
       "l" <- ("oldv" + #1);;
       "oldv" (* return old value *).

  (** Logically atomic spec for weak increment. Also an example for what TaDA
      calls "private precondition". *)
  (* TODO: Generalize to q and 1-q, based on some theory for a "maybe-mapsto"
     connective that works on [option Qp] (the type of 1-q). *)
  Lemma weak_incr_spec (l: loc) (v : Z) :
    l ↦{1/2} #v -∗
    <<< ∀ (v' : Z), l ↦{1/2} #v' >>>
      weak_incr #l @ ⊤
    <<< ⌜v = v'⌝ ∗ l ↦ #(v + 1), RET #v >>>.
  Proof.
    iIntros "Hl" (Φ) "AU". wp_lam.
    wp_apply (atomic_wp_seq $! (load_spec _) with "Hl").
    iIntros "Hl". awp_apply store_spec.
    (* Prove the atomic update for store *)
    iApply (aacc_aupd_commit with "AU"); first done.
    iIntros (x) "H↦".
    iDestruct (mapsto_agree with "Hl H↦") as %[= <-].
    iCombine "Hl" "H↦" as "Hl". iAaccIntro with "Hl".
    { iIntros "[$ $]"; eauto. }
    iIntros "$ !>". iSplit; first done.
    iIntros "HΦ !>". wp_seq. done.
  Qed.

End increment.

Section increment_client.
  Context `{!heapG Σ, !spawnG Σ}.

  Existing Instance primitive_atomic_heap.

  Definition incr_client : val :=
    λ: "x",
       let: "l" := ref "x" in
       incr "l" ||| incr "l".

  Lemma incr_client_safe (x: Z):
    ⊢ WP incr_client #x {{ _, True }}.
  Proof using Type*.
    wp_lam. wp_alloc l as "Hl".
    iMod (inv_alloc nroot _ (∃x':Z, l ↦ #x')%I with "[Hl]") as "#Hinv"; first eauto.
    (* FIXME: I am only using persistent stuff, so I should be allowed
       to move this to the persisten context even without the additional □. *)
    iAssert (□ WP incr #l {{ _, True }})%I as "#Aupd".
    { iIntros "!>". awp_apply incr_spec. clear x.
      iInv nroot as (x) ">H↦". iAaccIntro with "H↦"; first by eauto 10.
      iIntros "H↦ !>". iSplitL "H↦"; first by eauto 10.
      (* The continuation: From after the atomic triple to the postcondition of the WP *)
      done.
    }
    wp_apply wp_par.
    - iAssumption.
    - iAssumption.
    - iIntros (??) "_ !>". done.
  Qed.

End increment_client.


Require Import List.
Require Import Tactics.
Require Import Lists.
Require Import Id.
Import ListNotations.
Hint Constructors NoDup.

Fixpoint find_w (n: nat) (key: id) (l: list id) :=
  match l with
    | [] => None
    | (x :: xs) => if (key =? x)
                    then Some n
                    else find_w (S n) key xs
  end.

Definition find_where := (find_w 0).

Lemma notin_findwhere : forall x xs,
  ~In x xs -> find_where x xs = None.
Proof.
  intros.
  unfold find_where.
  generalize 0.
  induction xs; intros; [reflexivity | ].
  simpl in *.
  apply Decidable.not_or in H.
  destruct H.
  rewrite not_eq_beq_id_false; auto.
Qed.

Lemma in_findwhere : forall x xs,
  In x xs -> exists i, find_where x xs = Some i.
Proof.
  intros. unfold find_where. generalize 0.
  induction xs.
    - inversion H.
    - intros; simpl in *.
      destruct H.
      rewrite H.
      -- rewrite beq_id_refl; eauto.
      -- case eqb; eauto.
Qed.

Lemma find_w_S : forall xs n x i,
  find_w n x xs = Some i ->
  find_w (S n) x xs = Some (S i).
Proof.
  induction xs, n; intros; try (inversion H; auto); simpl.
  * case eqb eqn:Beq; simpl in *.
    ** inversion H1.
       reflexivity.
    ** apply beq_id_false_neq in Beq.
       rewrite not_eq_beq_id_false in *; auto.
  * case eqb eqn:Heq; simpl in *.
    ** inversion H1;eauto.
    ** apply IHxs; auto.
Qed.

Lemma findwhere_ntherror : forall xs x i,
  NoDup xs ->
  nth_error xs i = Some x ->
  find_where x xs = Some i.
Proof.
  induction xs; intros.
  * rewrite nth_error_nil in H0; inversion H0.
  * inversion H; subst.
    unfold find_where; simpl in *.
    case i in *.
    ** inversion H0.
       rewrite beq_id_refl.
       reflexivity.
    ** simpl in *.
       case eqb eqn:Heq.
       *** apply beq_id_eq in Heq.
           rewrite Heq in H0.
           apply nth_error_In in H0.
           contradiction.
       *** apply find_w_S.
           eapply IHxs; assumption.
Qed.

Section Ref.

  Class Referable (A: Set) :={
                               ref : A -> id;
                               find: id -> list A -> option A :=
                                 let fix f (key: id) (l: list A) :=
                                     match l with
                                     | [] => None
                                     | (x :: xs) => if eqb key (ref x)
                                                   then Some x
                                                   else f key xs
                                     end in f;
                             }.

  Lemma find_deterministic: forall `{R: Referable} d (k1: id) x1 x2,
      find k1 d = x1 ->
      find k1 d = x2 ->
      x1 = x2.
  Proof with eauto.
    intros.
    destruct x1, x2; destruct (@find A) in *; auto with rewrite; crush.
  Qed.

  Lemma find_dec: forall `{R: Referable} d (k: id),
      {exists x, find k d = Some x} + {find k d = None}.
  Proof.
    intros.
    induction d.
    * crush.
    * simpl.
      destruct beq_id_dec with (ref a) k.
      ** rewrite e.
         rewrite beq_id_refl; eauto.
      ** rewrite not_eq_beq_id_false; auto.
  Qed.

End Ref.

Module Refs.

  Definition refs {A: Set} {R: Referable A} (x: list A) := (map ref x).

  Hint Rewrite map_length.
  Lemma refs_lenght: forall  (A: Set) (R: @Referable A) xs,
      length (refs xs) = length xs.
  Proof. unfold refs; crush. Qed.
  Hint Rewrite refs_lenght.

End Refs.
Export Refs.

Section Findi.

  Inductive findi {A: Set} {R: @Referable A} : id -> list A -> A -> Prop:=
  | find_head : forall x xs, findi (ref x) (x :: xs) (x)
  | find_step : forall k1 k2 l x,
      k1 <> ref k2 -> findi k1 l x -> findi k1 (k2 :: l) x.

  Lemma findi_diff: forall (A: Set) (R: @Referable A) k a v l,
      k = ref a -> a <> v -> ~findi k (a :: l) v.
  Proof.
    intros A R k a v l H H0; intro H1.
    inversion H1; crush.
  Qed.

  Lemma find_iff_findi: forall (A: Set) (R: @Referable A) d (k1: id) (x1: A),
      find k1 d = Some x1 <-> findi k1 d x1.
  Proof.
    intros. split.
    intro H.
    induction d.
    inversion H.

    remember (ref a) as r.
    destruct beq_id_dec with (i1:= k1) (i2:= r); rewrite Heqr in *; clear Heqr.
    rewrite e in H; simpl in H. rewrite beq_id_refl in H.
    inversion H.
    rewrite e. rewrite H1.
    constructor.
    unfold find in H.
    rewrite not_eq_beq_id_false in H; auto.
    fold (@find A) in H.
    constructor.
    auto.
    apply IHd; auto.

    intro.
    induction H.
    simpl.
    rewrite beq_id_refl. auto.
    unfold find.
    rewrite not_eq_beq_id_false; auto.
  Qed.

  Lemma findi_none: forall (A: Set) (R: @Referable A) k l,
      find k l = None <-> (forall x, ~findi k l x).
  Proof.
    intros.
    split. intro. intros. intro. destruct H0. simpl in H.
    rewrite beq_id_refl in H. inversion H.
    apply <- find_iff_findi in H1.
    simpl in H. rewrite not_eq_beq_id_false in H; auto. rewrite H1 in H; inversion H.
    intros. induction l. reflexivity.
    simpl in *. destruct beq_id_dec with k (ref a).
    false. subst. destruct H with a. apply find_head.
    rewrite not_eq_beq_id_false; auto. apply IHl.
    intros. intro. destruct H with x. apply find_step; auto.
  Qed.

End Findi.

Lemma find_ref_inv: forall `{R: Referable} d (k: id) x,
    find k d = Some x ->
    ref x = k.
Proof.
  intros. apply find_iff_findi in H. induction H; crush.
Qed.

Lemma find_in: forall `{R: Referable} id xs x,
    find id xs = Some x ->
    In x xs.
Proof.
  intros.
  apply find_iff_findi in H. induction H; crush.
Qed.

Lemma Forall_find: forall `{R: Referable} P xs id x,
    Forall P xs ->
    find id xs = Some x ->
    P x.
Proof.
  intros.
  eapply Forall_forall in H; eauto.
  eapply find_in; eauto.
Qed.

Lemma in_imp_inref: forall {T} {H: Referable T} (xs:list T) x,
    In x xs ->
    In (ref x) (refs xs).
Proof.
  induction xs; crush.
Qed.

Lemma ref_noDup_nth_error: forall {T} {H: Referable T} (xs:list T) i i1 x x1,
    nth_error xs i = Some x ->
    nth_error xs i1 = Some x1 ->
    NoDup (refs xs) ->
    ref x = ref x1 ->
    x = x1.
Proof.
  induction xs; crush.
  destruct i; destruct i1; simpl in *; crush.
  rewrite H3 in H2. inversion H2. subst. clear H3.
  false. apply H5. apply nth_error_In in H1. apply in_imp_inref; eauto.
  rewrite <- H3 in H2. inversion H2. subst. false.
  apply H5. apply nth_error_In in H0. apply in_imp_inref; eauto.
  inversion H2.
  eapply IHxs; eauto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import List.
Require Import Setoid.
Require Import BinPos.
Require Import BinList.
Require Import Znumtheory.
Require Export Morphisms Setoid Bool.
Require Import ZArith.
Open Scope Z_scope.
Require Import Algebra_syntax.
Require Export Ring2.
Require Import Ring2_polynom.
Require Import Ring2_initial.

Set Implicit Arguments.

(* Reification with Type Classes, inspired from B.Grégoire and A.Spiewack *)

Class is_in_list_at (R:Type) (t:R) (l:list R) (i:nat) := {}.
Instance  Ifind0 (R:Type) (t:R) l
 : is_in_list_at t (t::l) 0.
Instance  IfindS (R:Type) (t2 t1:R) l i
 `{is_in_list_at R t1 l i}
 : is_in_list_at t1 (t2::l) (S i) | 1.

Class reifyPE (R:Type) (e:PExpr Z) (lvar:list R) (t:R) := {}.
Instance  reify_zero (R:Type) (RR:Ring R) lvar
 : reifyPE (PEc 0%Z) lvar ring0.
Instance  reify_one (R:Type) (RR:Ring R) lvar
 : reifyPE (PEc 1%Z) lvar ring1.
Instance  reify_plus (R:Type)  (RR:Ring R)
  e1 lvar t1 e2 t2
 `{reifyPE R e1 lvar t1}
 `{reifyPE R e2 lvar t2}
 : reifyPE (PEadd e1 e2) lvar (ring_plus t1 t2).
Instance  reify_mult (R:Type)  (RR:Ring R)
  e1 lvar t1 e2 t2
 `{reifyPE R e1 lvar t1}
 `{reifyPE R e2 lvar t2}
 : reifyPE (PEmul e1 e2) lvar (ring_mult t1 t2).
Instance  reify_sub (R:Type) (RR:Ring R)
 e1 lvar t1 e2 t2
 `{reifyPE R e1 lvar t1}
 `{reifyPE R e2 lvar t2}
 : reifyPE (PEsub e1 e2) lvar (ring_sub t1 t2).
Instance  reify_opp (R:Type) (RR:Ring R)
 e1 lvar t1
 `{reifyPE R e1 lvar t1}
 : reifyPE (PEopp e1) lvar (ring_opp t1).
Instance  reify_var (R:Type) t lvar i
 `{is_in_list_at R t lvar i}
 : reifyPE (PEX Z (P_of_succ_nat i)) lvar t
 | 100.

Class reifyPElist (R:Type) (lexpr:list (PExpr Z)) (lvar:list R)
  (lterm:list R) := {}.
Instance reifyPE_nil (R:Type) lvar
 : @reifyPElist R nil lvar (@nil R).
Instance reifyPE_cons (R:Type) e1 lvar t1 lexpr2 lterm2
 `{reifyPE R e1 lvar t1} `{reifyPElist R lexpr2 lvar lterm2}
 : reifyPElist (e1::lexpr2) lvar (t1::lterm2).

Class is_closed_list T (l:list T) := {}.
Instance Iclosed_nil T
 : is_closed_list (T:=T) nil.
Instance Iclosed_cons T t l
 `{is_closed_list (T:=T) l}
 : is_closed_list (T:=T) (t::l).

Definition list_reifyl (R:Type) lexpr lvar lterm
 `{reifyPElist R lexpr lvar lterm}
 `{is_closed_list (T:=R) lvar} := (lvar,lexpr).

Unset Implicit Arguments.

Instance multiplication_phi_ring{R:Type}{Rr:Ring R} : Multiplication  :=
  {multiplication x y := ring_mult (gen_phiZ Rr x) y}.

(*
Print HintDb typeclass_instances.
*)
(* Reification *)

Ltac lterm_goal g :=
  match g with
  ring_eq ?t1 ?t2 => constr:(t1::t2::nil)
  | ring_eq ?t1 ?t2 -> ?g => let lvar :=
    lterm_goal g in constr:(t1::t2::lvar)
  end.

Ltac reify_goal lvar lexpr lterm:=
(*  idtac lvar; idtac lexpr; idtac lterm;*)
  match lexpr with
     nil => idtac
   | ?e::?lexpr1 =>
        match lterm with
         ?t::?lterm1 => (* idtac "t="; idtac t;*)
           let x := fresh "T" in
           set (x:= t);
           change x with
             (@PEeval Z Zr _ _ (@gen_phiZ_morph _ _) N
                      (fun n:N => n) (@Ring_theory.pow_N _ ring1 ring_mult)
                      lvar e);
           clear x;
           reify_goal lvar lexpr1 lterm1
        end
  end.

Existing Instance gen_phiZ_morph.
Existing Instance Zr.

Lemma comm: forall (R:Type)(Rr:Ring R)(c : Z) (x : R),
  x * [c] == [c] * x.
induction c. intros. ring_simpl. gen_ring_rewrite. simpl. intros.
ring_rewrite_rev same_gen.
induction p. simpl.  gen_ring_rewrite. ring_rewrite IHp. rrefl.
simpl.  gen_ring_rewrite. ring_rewrite IHp. rrefl.
simpl.  gen_ring_rewrite.
simpl. intros. ring_rewrite_rev same_gen.
induction p. simpl. generalize IHp. clear IHp.
gen_ring_rewrite. intro IHp.  ring_rewrite IHp. rrefl.
simpl. generalize IHp. clear IHp.
gen_ring_rewrite. intro IHp.  ring_rewrite IHp. rrefl.
simpl.  gen_ring_rewrite. Qed.

Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y.
 intros x y H. rewrite (Zeq_bool_eq x y H). rrefl. Qed.

 Ltac ring_gen :=
   match goal with
     |- ?g => let lterm := lterm_goal g in (* les variables *)
       match eval red in (list_reifyl (lterm:=lterm)) with
         | (?fv, ?lexpr) =>
(*         idtac "variables:";idtac fv;
           idtac "terms:"; idtac lterm;
           idtac "reifications:"; idtac lexpr;
*)
           reify_goal fv lexpr lterm;
           match goal with
             |- ?g =>
               set_ring_notations;
               apply (@ring_correct Z Zr _ _ (@gen_phiZ_morph _ _)
                 (@comm _ _) Zeq_bool Zeqb_ok N (fun n:N => n)
                 (@Ring_theory.pow_N _  1 multiplication));
               [apply mkpow_th; rrefl
                 |vm_compute; reflexivity]
           end
       end
   end.

(* Pierre L: these tests should be done in a section, otherwise
   global axioms are generated. Ideally such tests should go in
   the test-suite directory *)
Section Tests.

Ltac ring2:=
  unset_ring_notations; intros;
  match goal with
    |- (@ring_eq ?r ?rd _ _ ) =>
          simpl; ring_gen
  end.
Variable R: Type.
Variable Rr: Ring R.
Existing Instance Rr.

Goal forall x y z:R, x  == x .
ring2.
Qed.

Goal forall x y z:R, x * y * z == x * (y * z).
ring2.
Qed.

Goal forall x y z:R, [3]* x *([2]* y * z) == [6] * (x * y) * z.
ring2.
Qed.

Goal forall x y z:R, 3 * x * (2 * y * z) == 6 * (x * y) * z.
ring2.
Qed.

(* Fails with Multiplication: A -> B -> C.
Goal forall x:R,    2%Z * (x * x) == 3%Z * x.
Admitted.
*)

End Tests.