(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List Psatz.

Require Import BasicFacts ListFacts OrderedSet Signatures.

Set Implicit Arguments.

Module NestedLoop.
Section Sec.

Hypotheses o1 o2 o : Type.
Hypothesis O1 : Oeset.Rcd o1.
Hypothesis O2 : Oeset.Rcd o2.
Hypothesis O : Oeset.Rcd o.

Hypothesis build_ : o1 -> o2 -> o.
Hypothesis build_eq_1  :
  forall x1 x1' x2,
    Oeset.compare O1 x1 x1' = Eq -> Oeset.compare O (build_ x1 x2) (build_ x1' x2) = Eq.
Hypothesis build_eq_2  :
  forall x1 x2 x2',
    Oeset.compare O2 x2 x2' = Eq -> Oeset.compare O (build_ x1 x2) (build_ x1 x2') = Eq.

Hypothesis C1 : Cursor.Rcd O1.
Hypothesis C2 : Cursor.Rcd O2.

Record cursor :=
  mk_cursor
    {
      visited: list o;
      outer: Cursor.cursor C1;
      inner: Cursor.cursor C2
    }.

Local Notation cross := (fun l1 l2 => flat_map (fun a => (map (build_ a) l2)) l1).

Lemma map_build_eq :
  forall a1 b1 l2 m2,
    Oeset.compare O1 a1 b1 = Eq -> comparelA (Oeset.compare O2) l2 m2 = Eq ->
    comparelA (Oeset.compare O) (map (build_ a1) l2) (map (build_ b1) m2) = Eq.
Proof.
intros a1 b1 l2; induction l2 as [ | a2 l2]; intros [ | b2 m2] H1 H2; try discriminate H2; trivial.
simpl in H2.
case_eq (Oeset.compare O2 a2 b2); intro Ha2; rewrite Ha2 in H2; try discriminate H2.
simpl.
rewrite (Oeset.compare_eq_1 _ _ _ _ (build_eq_1 _ _ _ H1)).
rewrite (Oeset.compare_eq_1 _ _ _ _ (build_eq_2 _ _ _ Ha2)).
rewrite Oeset.compare_eq_refl.
apply IHl2; trivial.
Qed.

Lemma cross_eq : forall l1 l2 m1 m2,
    comparelA (Oeset.compare O1) l1 m1 = Eq -> comparelA (Oeset.compare O2) l2 m2 = Eq ->
    comparelA
      (Oeset.compare O)
      (flat_map (fun a => (map (build_ a) l2)) l1)
      (flat_map (fun a => (map (build_ a) m2)) m1) = Eq.
Proof.
intro l1; induction l1 as [ | x1 l1];
  (intros l2 [ | y1 m1] m2 H1 H2; simpl; trivial; try discriminate H1).
simpl in H1.
case_eq (Oeset.compare O1 x1 y1); intro Hx1; rewrite Hx1 in H1; try discriminate H1.
apply comparelA_eq_app; [ | apply IHl1; trivial].
apply map_build_eq; trivial.
Qed.

Definition collection c :=
  cross (Cursor.collection (outer c)) (Cursor.collection (inner c)).

Definition coherent (c: cursor) : Prop :=
  (* the two underlying cursors are coherent *)
  Cursor.coherent (outer c) /\ Cursor.coherent (inner c) /\
  match (Cursor.visited (outer c)) with
  (* if the outer cursor has not been visited yet, so as the inner
     cursor *)
  | nil => visited c = nil /\ Cursor.visited (inner c) = nil
  (* otherwise, the visited elements are a partial cross-product *)
  | el :: li =>
    comparelA
      (Oeset.compare O)
      (visited c)
      ((cross (el::nil) (Cursor.visited (inner c))) ++
         (cross li (rev (Cursor.collection (inner c))))) = Eq
  end.

Lemma visited_collection :
  forall c, coherent c ->
    forall x, Oeset.mem_bool O x (visited c) = true -> Oeset.mem_bool O x (collection c) = true.
Proof.
intros c Hc x Hx; unfold coherent in Hc; unfold collection.
destruct Hc as [Hc1 [Hc2 H]].
case_eq (Cursor.visited (outer c)).
- intro H1; rewrite H1 in H.
  rewrite (proj1 H) in Hx; discriminate Hx.
-  intros x1 l H1; rewrite H1 in H.
   rewrite (Oeset.mem_bool_eq_2 _ _ _ _ H), Oeset.mem_bool_app, Bool.orb_true_iff in Hx.
   destruct Hx as [Hx | Hx].
   + rewrite Oeset.mem_bool_true_iff in Hx.
     destruct Hx as [x' [Hx Hx']].
     rewrite in_flat_map in Hx'.
     destruct Hx' as [_x' [_Hx' Hx']].
     simpl in _Hx'; destruct _Hx' as [_Hx' | _Hx']; [ | contradiction _Hx']; subst _x'.
     rewrite in_map_iff in Hx'.
     destruct Hx' as [x2 [Hx' Hx2]]; subst x'.
     assert (Kx1 : Oeset.mem_bool O1 x1 (Cursor.collection (outer c)) = true).
     {
       apply (Cursor.visited_collection (outer c) Hc1).
       rewrite Oeset.mem_bool_true_iff, H1; exists x1; split; [ | left; trivial].
       apply Oeset.compare_eq_refl.
     }
     assert (Kx2 : Oeset.mem_bool O2 x2 (Cursor.collection (inner c)) = true).
     {
       apply (Cursor.visited_collection (inner c) Hc2).
       rewrite Oeset.mem_bool_true_iff; exists x2; split; [ | trivial].
       apply Oeset.compare_eq_refl.
     }
     rewrite Oeset.mem_bool_true_iff in Kx1, Kx2.
     destruct Kx1 as [y1 [Kx1 Hy1]].
     destruct Kx2 as [y2 [Ky2 Hy2]].
     rewrite (Oeset.mem_bool_eq_1 _ _ (build_ y1 y2)), Oeset.mem_bool_true_iff.
     * eexists; split; [apply Oeset.compare_eq_refl | ].
       rewrite in_flat_map; exists y1; split; [assumption | ].
       rewrite in_map_iff; exists y2; split; trivial.
     * rewrite (Oeset.compare_eq_1 _ _ _ _ Hx).
       rewrite (Oeset.compare_eq_1 _ _ _ _ (build_eq_1 _ _ _ Kx1)); apply build_eq_2; assumption.
   + rewrite Oeset.mem_bool_true_iff in Hx.
     destruct Hx as [x' [Hx Hx']].
     rewrite in_flat_map in Hx'.
     destruct Hx' as [y1 [Hx1 Hx']].
     rewrite in_map_iff in Hx'.
     destruct Hx' as [y2 [Hx' Hy2]]; subst x'.
     assert (Ky1 : Oeset.mem_bool O1 y1 (Cursor.collection (outer c)) = true).
     {
       apply (Cursor.visited_collection (outer c) Hc1).
       rewrite Oeset.mem_bool_true_iff, H1; exists y1; split; [ | right; trivial].
       apply Oeset.compare_eq_refl.
     }
     rewrite Oeset.mem_bool_true_iff in Ky1.
     destruct Ky1 as [z1 [Ky1 Hz1]].
     rewrite (Oeset.mem_bool_eq_1 _ _ (build_ z1 y2)), Oeset.mem_bool_true_iff.
     * eexists; split; [apply Oeset.compare_eq_refl | ].
       rewrite in_flat_map; exists z1; split; [assumption | ].
       rewrite in_map_iff; exists y2; split; [trivial | ].
       rewrite in_rev; assumption.
     * rewrite (Oeset.compare_eq_1 _ _ _ _ Hx).
       apply build_eq_1; assumption.
Qed.

Definition reset (c : cursor) : cursor :=
    mk_cursor nil (Cursor.reset (outer c)) (Cursor.reset (inner c)).

Lemma reset_collection : forall c, collection (reset c) = collection c.
Proof.
intro c; unfold reset, collection; simpl.
rewrite 2 Cursor.reset_collection; apply refl_equal.
Qed.

Lemma reset_visited : forall c, visited (reset c) = nil.
Proof.
intro c; unfold reset; apply refl_equal.
Qed.

Lemma reset_coherent : forall c, coherent (reset c).
Proof.
intro c; unfold reset, coherent; simpl.
split; [apply Cursor.reset_coherent | ].
split; [apply Cursor.reset_coherent | ].
rewrite 2 Cursor.reset_visited; split; trivial.
Qed.

Definition next (c: cursor) : (result o * cursor) :=
  match Cursor.next (inner c) with
  | (Empty_Cursor, c2') =>
    match Cursor.next (outer c) with
    | (Empty_Cursor, _) => (Empty_Cursor, mk_cursor (visited c) (outer c) c2')
    | (No_Result, c1') =>
      let c2'' := Cursor.reset (inner c) in
      match Cursor.next c2'' with
      | (Empty_Cursor, _) => (Empty_Cursor, mk_cursor (visited c) c1' c2')
      | _ => (No_Result, mk_cursor (visited c) c1' c2')
      end
    | (Result e1, c1') =>
      let c2' := Cursor.reset (inner c) in
      match Cursor.next c2' with
      | (Empty_Cursor, c2') => (Empty_Cursor, mk_cursor (visited c) c1' c2')
      | (No_Result, c2') => (No_Result, mk_cursor (visited c) c1' c2')
      | (Result e2, c2') =>
        let e := (build_ e1 e2) in
        (Result e, mk_cursor (e :: visited c) c1' c2')
      end
    end
  | (Result e2, c2') =>
    match Cursor.visited (outer c) with
    | nil => match Cursor.next (outer c) with
             | (Empty_Cursor, c1') => (Empty_Cursor, mk_cursor (visited c) c1' (inner c))
             | (Result e1, c1') => let e := build_ e1 e2 in
                              (Result e, mk_cursor (e :: visited c) c1' c2')
             | (No_Result, c1') => (No_Result, mk_cursor (visited c) c1' (inner c))
          end
    | e1 :: _ => let e := build_ e1 e2 in
                (Result e, mk_cursor (e :: visited c) (outer c) c2')
    end
  | (No_Result, c2') =>
    (No_Result, mk_cursor (visited c) (outer c) c2')
  end.

Lemma next_collection :
  forall c c' res, coherent c -> next c = (res, c') -> collection c' = collection c.
Proof.
intros c c' res Hc H; unfold coherent in Hc.
destruct Hc as [Hc1 [Hc2 Hc]].
unfold next in H.
case_eq (Cursor.next (inner c)); intros r2 c2' Hnc2; rewrite Hnc2 in H.
destruct r2 as [e2 | | ].
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in H.
    case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
    destruct r1 as [e1 | | ]; injection H; clear H; intros H1 H2; subst; unfold collection; simpl.
    * rewrite (Cursor.next_collection _ _ Hc1 Hnc1).
      rewrite (Cursor.next_collection _ _ Hc2 Hnc2).
      apply refl_equal.
    * rewrite (Cursor.next_collection _ _ Hc1 Hnc1); apply refl_equal.
    * rewrite (Cursor.next_collection _ _ Hc1 Hnc1).
      apply refl_equal.
  + intros v1 lv1 Hvc1; rewrite Hvc1 in H.
    injection H; clear H; intros H1 H2; subst; unfold collection; simpl.
    rewrite (Cursor.next_collection _ _ Hc2 Hnc2); apply refl_equal.
- injection H; clear H; intros H1 H2; subst; unfold collection; simpl.
  rewrite (Cursor.next_collection _ _ Hc2 Hnc2); apply refl_equal.
- case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
  destruct r1 as [e1 | | ].
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
    destruct r2 as [e2 | | ]; injection H; clear H; intros H1 H2; subst; unfold collection; simpl.
    * rewrite (Cursor.next_collection _ _ Hc1 Hnc1).
      rewrite (Cursor.next_collection _ _ (Cursor.reset_coherent _) Hnc2').
      rewrite Cursor.reset_collection; apply refl_equal.
    * rewrite (Cursor.next_collection _ _ Hc1 Hnc1).
      rewrite (Cursor.next_collection _ _ (Cursor.reset_coherent _) Hnc2').
      rewrite Cursor.reset_collection; apply refl_equal.
    * rewrite (Cursor.next_collection _ _ Hc1 Hnc1).
      rewrite (Cursor.next_collection _ _ (Cursor.reset_coherent _) Hnc2').
      rewrite Cursor.reset_collection; apply refl_equal.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
    destruct r2 as [e2 | | ]; injection H; intros; subst res c'; unfold collection; simpl;
      rewrite (Cursor.next_collection _ _ Hc1 Hnc1), (Cursor.next_collection _ _ Hc2 Hnc2);
      apply refl_equal.
  + injection H; clear H; intros H1 H2; subst; unfold collection; simpl.
    rewrite (Cursor.next_collection _ _ Hc2 Hnc2).
    apply refl_equal.
Qed.

Lemma next_visited_Result:
  forall e c c', coherent c -> next c = (Result e, c') -> visited c' = e :: visited c.
Proof.
intros e c c' Hc H; unfold coherent in Hc.
unfold next in H.
case_eq (Cursor.next (inner c)); intros r2 c2' Hnc2; rewrite Hnc2 in H.
destruct r2 as [e2 | | ]; try discriminate H.
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in H.
    case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
    destruct r1 as [e1 | | ]; try discriminate H.
    injection H; clear H; intros H1 H2; subst; simpl; trivial.
  + intros v1 lv1 Hvc1; rewrite Hvc1 in H.
    injection H; clear H; intros H1 H2; subst; simpl; trivial.
- case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
  destruct r1 as [e1 | | ]; try discriminate H.
  case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
  destruct r2 as [e2 | | ]; try discriminate H.
  + injection H; clear H; intros H1 H2; subst; simpl; trivial.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H;
      destruct r2 as [e2 | | ]; try discriminate H.
Qed.

Lemma next_visited_No_Result :
  forall c c', coherent c -> next c = (No_Result, c') -> visited c' = visited c.
Proof.
intros c c' Hc H; unfold coherent in Hc.
unfold next in H.
case_eq (Cursor.next (inner c)); intros r2 c2' Hnc2; rewrite Hnc2 in H.
destruct r2 as [e2 | | ].
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in H.
    case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
    destruct r1 as [e1 | | ]; try discriminate H.
    injection H; clear H; intros H1; subst; simpl; trivial.
  + intros v1 lv1 Hvc1; rewrite Hvc1 in H; discriminate H.
- injection H; clear H; intros H1; subst; simpl; trivial.
- case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
  destruct r1 as [e1 | | ]; try discriminate H.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
    destruct r2 as [e2 | | ]; try discriminate H.
    injection H; clear H; intros H1; subst; simpl; trivial.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H;
      destruct r2 as [e2 | | ]; try discriminate H.
    * injection H; clear H; intros H1; subst; simpl; trivial.
    * injection H; clear H; intros H1; subst; simpl; trivial.
Qed.

Lemma next_visited_Empty_Cursor :
  forall c c', coherent c -> next c = (Empty_Cursor, c') -> visited c' = visited c.
Proof.
intros c c' Hc H; unfold coherent in Hc.
unfold next in H.
case_eq (Cursor.next (inner c)); intros r2 c2' Hnc2; rewrite Hnc2 in H.
destruct r2 as [e2 | | ]; try discriminate H.
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in H.
    case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
    destruct r1 as [e1 | | ]; try discriminate H.
    injection H; clear H; intros H1; subst; simpl; trivial.
  + intros v1 lv1 Hvc1; rewrite Hvc1 in H.
    discriminate H.
- case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
  destruct r1 as [e1 | | ]; try discriminate H.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
    destruct r2 as [e2 | | ]; try discriminate H.
    injection H; clear H; intros H1; subst; simpl; trivial.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H;
      destruct r2 as [e2 | | ]; try discriminate H.
    injection H; clear H; intros H1; subst; simpl; trivial.
  + injection H; clear H; intros H1; subst; simpl; trivial.
Qed.

Lemma next_coherent: forall c, coherent c -> coherent (snd (next c)).
Proof.
unfold coherent, next; intros c Hc.
destruct Hc as [Hc1 [Hc2 Hc]].
case_eq (Cursor.next (inner c)); intros r2 c2' Hnc2.
destruct r2 as [e2 | | ].
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in Hc.
    case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1.
    destruct r1 as [e1 | | ]; simpl.
    * split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
      split; [assert (H2 := Cursor.next_coherent _ _ Hc2); rewrite Hnc2 in H2; apply H2 | ].
      rewrite (Cursor.next_visited_Result _ _ Hc1 Hnc1), Hvc1, <- 2 app_nil_end.
      rewrite (Cursor.next_visited_Result _ _ Hc2 Hnc2), map_unfold, Oeset.compare_eq_refl.
      rewrite (proj1 Hc), (proj2 Hc); apply refl_equal.
    * split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
      split; [assumption | ].
      rewrite (Cursor.next_visited_No_Result _ _ Hc1 Hnc1), Hvc1; apply Hc.
    * split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
      split; [assumption | ].
      rewrite (Cursor.next_visited_Empty_Cursor _ _ Hc1 Hnc1), Hvc1.
      apply Hc.
  + intros v1 lv1 Hvc1; rewrite Hvc1 in Hc; simpl.
    split; [assumption | ].
    split; [assert (H2 := Cursor.next_coherent _ _ Hc2); rewrite Hnc2 in H2; apply H2 | ].
    rewrite Hvc1, (Cursor.next_visited_Result _ _ Hc2 Hnc2), map_unfold, <- app_nil_end; simpl.
    rewrite Oeset.compare_eq_refl, (Cursor.next_collection _ _ Hc2 Hnc2).
    simpl flat_map in Hc; rewrite <- app_nil_end in Hc; apply Hc.
- simpl; split; [assumption | ].
  split; [assert (H2 := Cursor.next_coherent _ _ Hc2); rewrite Hnc2 in H2; apply H2 | ].
  case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in Hc; split; [apply (proj1 Hc) | ].
    rewrite <- (proj2 Hc).
    apply (Cursor.next_visited_No_Result _ _ Hc2 Hnc2).
  + intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
    simpl flat_map in Hc; rewrite <- app_nil_end in Hc.
    rewrite <- app_nil_end.
    rewrite (Cursor.next_collection _ _ Hc2 Hnc2).
    rewrite (Cursor.next_visited_No_Result _ _ Hc2 Hnc2).
    apply Hc.
- case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; simpl.
  destruct r1 as [e1 | | ].
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'.
    destruct r2 as [e2 | | ]; simpl.
    * rewrite (Cursor.next_visited_Result _ _ Hc1 Hnc1), <- app_nil_end.
      rewrite (Cursor.next_visited_Result _ _ (Cursor.reset_coherent (inner c)) Hnc2').
      rewrite map_unfold; simpl; rewrite Oeset.compare_eq_refl.
      rewrite Cursor.reset_visited, map_unfold; simpl app.
      {
        case_eq (Cursor.visited (outer c)).
        - intro Hvc1; rewrite Hvc1 in Hc.
          split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
          split; [assert (Hc2' := Cursor.reset_coherent (inner c));
                  assert (Hc2'' := Cursor.next_coherent _ _ Hc2'); rewrite Hnc2' in Hc2'';
                  apply Hc2'' | ].
          rewrite (proj1 Hc); apply refl_equal.
        - intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
          rewrite <- (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2) in Hc.
          simpl flat_map in Hc;
            rewrite <- app_nil_end, (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2) in Hc.
          rewrite (Cursor.next_collection _ _ (Cursor.reset_coherent (inner c)) Hnc2').
          rewrite Cursor.reset_collection.
          split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
          split; [assert (Hc2' := Cursor.reset_coherent (inner c));
                  assert (Hc2'' := Cursor.next_coherent _ _ Hc2'); rewrite Hnc2' in Hc2'';
                  apply Hc2'' | ].
          refine (comparelA_eq_trans _ _ _ _ _ Hc _).
          + do 6 intro; apply Oeset.compare_eq_trans.
          + simpl.
            apply comparelA_eq_app;
                     [ | apply comparelA_eq_refl; intros; apply Oeset.compare_eq_refl].
            apply map_build_eq; [apply Oeset.compare_eq_refl | ].
            rewrite <- (rev_involutive (Cursor.visited (inner c))).
            apply comparelA_rev_eq; rewrite comparelA_lt_gt;
              [ | intros; apply Oeset.compare_lt_gt].
            rewrite CompOpp_iff; apply (Cursor.has_next_spec Hc2).
            intro H; rewrite (Cursor.has_next_next_neg _ _ Hc2), Hnc2 in H.
            apply H; apply refl_equal.
      }
    * split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
      split; [assert (Hc2' := Cursor.reset_coherent (inner c));
      assert (Hc2'' := Cursor.next_coherent _ _ Hc2'); rewrite Hnc2' in Hc2''; apply Hc2'' | ].
      rewrite (Cursor.next_visited_Result _ _ Hc1 Hnc1), <- app_nil_end.
      rewrite (Cursor.next_visited_No_Result _ _ (Cursor.reset_coherent (inner c)) Hnc2').
      rewrite Cursor.reset_visited; simpl.
      {
        case_eq (Cursor.visited (outer c)).
        - intro Hvc1; rewrite Hvc1 in Hc.
          rewrite (proj1 Hc); apply refl_equal.
        - intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
          rewrite <- (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2) in Hc.
          simpl flat_map in Hc;
            rewrite <- app_nil_end, (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2) in Hc.
          rewrite (Cursor.next_collection _ _ (Cursor.reset_coherent (inner c)) Hnc2').
          rewrite Cursor.reset_collection.
          refine (comparelA_eq_trans _ _ _ _ _ Hc _).
          + do 6 intro; apply Oeset.compare_eq_trans.
          + simpl.
            apply comparelA_eq_app;
                     [ | apply comparelA_eq_refl; intros; apply Oeset.compare_eq_refl].
            apply map_build_eq; [apply Oeset.compare_eq_refl | ].
            rewrite <- (rev_involutive (Cursor.visited (inner c))).
            apply comparelA_rev_eq; rewrite comparelA_lt_gt;
              [ | intros; apply Oeset.compare_lt_gt].
            rewrite CompOpp_iff; apply (Cursor.has_next_spec Hc2).
            intro H; rewrite (Cursor.has_next_next_neg _ _ Hc2), Hnc2 in H.
            apply H; apply refl_equal.
      }
    * split; [assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; apply H1 | ].
      split; [assert (Hc2' := Cursor.reset_coherent (inner c));
      assert (Hc2'' := Cursor.next_coherent _ _ Hc2'); rewrite Hnc2' in Hc2''; apply Hc2'' | ].
      rewrite (Cursor.next_visited_Result _ _ Hc1 Hnc1), <- app_nil_end.
      rewrite (Cursor.next_visited_Empty_Cursor _ _ (Cursor.reset_coherent (inner c)) Hnc2').
      rewrite Cursor.reset_visited; simpl.
      {
        case_eq (Cursor.visited (outer c)).
        - intro Hvc1; rewrite Hvc1 in Hc.
          rewrite (proj1 Hc); apply refl_equal.
        - intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
          rewrite <- (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2) in Hc.
          simpl flat_map in Hc;
            rewrite <- app_nil_end, (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2) in Hc.
          rewrite (Cursor.next_collection _ _ (Cursor.reset_coherent (inner c)) Hnc2').
          rewrite Cursor.reset_collection.
          refine (comparelA_eq_trans _ _ _ _ _ Hc _).
          + do 6 intro; apply Oeset.compare_eq_trans.
          + simpl.
            apply comparelA_eq_app;
                     [ | apply comparelA_eq_refl; intros; apply Oeset.compare_eq_refl].
            apply map_build_eq; [apply Oeset.compare_eq_refl | ].
            rewrite <- (rev_involutive (Cursor.visited (inner c))).
            apply comparelA_rev_eq; rewrite comparelA_lt_gt;
              [ | intros; apply Oeset.compare_lt_gt].
            rewrite CompOpp_iff; apply (Cursor.has_next_spec Hc2).
            intro H; rewrite (Cursor.has_next_next_neg _ _ Hc2), Hnc2 in H.
            apply H; apply refl_equal.
      }
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'.
    assert (H1 := Cursor.next_coherent _ _ Hc1); rewrite Hnc1 in H1; simpl in H1.
    assert (H2 := Cursor.next_coherent _ _ Hc2); rewrite Hnc2 in H2; simpl in H2.
    assert (K1 := Cursor.next_visited_No_Result _ _ Hc1 Hnc1).
    assert (K2 := Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2).
    assert (K2' := Cursor.next_collection _ _ Hc2 Hnc2).
    simpl in Hc.
    destruct r2 as [e2 | | ]; simpl;
      (split; [apply H1 | ]; split; [apply H2 | ]; rewrite K1, K2;
       case_eq (Cursor.visited (outer c));
       [intro Hvc1 | intros v1 lv1 Hvc1]; rewrite Hvc1 in Hc; [trivial | rewrite K2'; trivial]).
  + simpl.
    split; [assumption | ].
    split; [assert (H2 := Cursor.next_coherent _ _ Hc2); rewrite Hnc2 in H2; apply H2 | ].
    rewrite (Cursor.next_visited_Empty_Cursor _ _ Hc2 Hnc2).
    case_eq (Cursor.visited (outer c)).
    * intro Hvc1; rewrite Hvc1 in Hc; apply Hc.
    * intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
      rewrite (Cursor.next_collection _ _ Hc2 Hnc2).
      apply Hc.
Qed.

Lemma next_Empty_Cursor :
  forall c, coherent c -> fst (next c) = Empty_Cursor -> fst (next (snd (next c))) = Empty_Cursor.
Proof.
unfold coherent, next; intros c Hc H.
destruct Hc as [Hc1 [Hc2 Hc]].
case_eq (Cursor.next (inner c)); intros r2 c2' Hnc2; rewrite Hnc2 in H.
destruct r2 as [e2 | | ].
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in Hc.
    case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
    destruct r1 as [e1 | | ]; simpl.
    * destruct (Cursor.visited (outer c)); discriminate H.
    * destruct (Cursor.visited (outer c)); discriminate H.
    * rewrite (Cursor.next_visited_Empty_Cursor _ _ Hc1 Hnc1), Hvc1, Hnc2.
      assert (K : fst (Cursor.next (snd (Empty_Cursor (A := o1), c1'))) = Empty_Cursor).
      {
        rewrite <- Hnc1.
        apply Cursor.next_Empty_Cursor; [assumption | ].
        rewrite Hnc1; trivial.
      }
      simpl in K.
      case_eq (Cursor.next c1'); intros r1 c1'' Hnc1'; rewrite Hnc1' in K; simpl in K; subst r1.
      apply refl_equal.
  + intros v1 lv1 Hvc1; rewrite Hvc1 in H; discriminate H.
- discriminate H.
- case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
  destruct r1 as [e1 | | ].
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
    destruct r2 as [e2 | | ]; try discriminate H.
    simpl.
    rewrite (Cursor.next_visited_Result _ _ Hc1 Hnc1).
    assert (K : fst (Cursor.next (snd (Cursor.next (Cursor.reset (inner c))))) = Empty_Cursor).
    {
      apply (Cursor.next_Empty_Cursor _ _ (Cursor.reset_coherent (inner c))).
      rewrite Hnc2'; trivial.
    }
    rewrite Hnc2' in K; simpl in K.
    case_eq (Cursor.next c2''); intros r2 c2''' Hnc2''; rewrite Hnc2'' in K; simpl in K; subst r2.
    case_eq (Cursor.next c1'); intros r1 c1'' Hnc1'.
    assert (K := Cursor.next_reset _ _ (Cursor.reset_coherent (inner c))).
    rewrite Hnc2' in K; simpl in K; rewrite K, Cursor.reset_reset, Hnc2'.
    destruct r1; trivial.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
    destruct r2 as [e2 | | ]; try discriminate H.
    simpl.
    assert (K : fst (Cursor.next (snd (Cursor.next (inner c)))) = Empty_Cursor).
    {
      apply (Cursor.next_Empty_Cursor _ _ Hc2).
      rewrite Hnc2; trivial.
    }
    rewrite Hnc2 in K; simpl in K.
    case_eq (Cursor.next c2'); intros r2 c2''' Hnc2''; rewrite Hnc2'' in K; simpl in K; subst r2.
    assert (K := Cursor.next_reset _ _ Hc2).
    rewrite Hnc2 in K; simpl in K; rewrite K, Hnc2'.
    case_eq (Cursor.next c1'); intros r1 c1'' Hnc1'.
    destruct r1; trivial.
  + simpl.
    assert (K : fst (Cursor.next (snd (Cursor.next (inner c)))) = Empty_Cursor).
    {
      apply (Cursor.next_Empty_Cursor _ _ Hc2).
      rewrite Hnc2; trivial.
    }
    rewrite Hnc2 in K; simpl in K.
    case_eq (Cursor.next c2'); intros r2 c2'' Hnc2'; rewrite Hnc2' in K; simpl in K; subst r2.
    rewrite Hnc1; trivial.
Qed.

Definition has_next (c : cursor) : Prop := fst (next c) <> Empty_Cursor.

Lemma has_next_spec:
  forall c, coherent c -> ~ (has_next c) ->
            comparelA (Oeset.compare O) (collection c) (rev (visited c)) = Eq.
Proof.
unfold coherent; intros c [Hc1 [Hc2 Hc]] H.
unfold has_next in H; unfold collection.
case_eq (fst (next c)).
- intros a Ha; rewrite Ha in H; apply False_rec; apply H; discriminate.
- intros Ha; rewrite Ha in H; apply False_rec; apply H; discriminate.
- clear H; intro H.
  unfold next in H.
  case_eq (Cursor.next (inner c)).
  intros r2 c2' Hnc2; rewrite Hnc2 in H.
  destruct r2 as [e2 | | ]; try discriminate H.
  + case_eq (Cursor.visited (outer c)).
    * intro Hvc1; rewrite Hvc1 in H.
      case_eq (Cursor.next (outer c)).
      intros r1 c1' Hnc1; rewrite Hnc1 in H.
      destruct r1 as [e1 | | ]; try discriminate H.
      rewrite Hvc1 in Hc.
      rewrite (proj1 Hc); simpl.
      assert (H1 : comparelA (Oeset.compare O1) (Cursor.collection (outer c))
         (rev (Cursor.visited (outer c))) = Eq).
      {
        apply (Cursor.has_next_spec Hc1).
        intro H1.
        rewrite Cursor.has_next_next_neg, Hnc1 in H1.
        - apply H1; apply refl_equal.
        - apply Hc1.
      }
      rewrite Hvc1 in H1.
      destruct (Cursor.collection (outer c)); [ | discriminate H1].
      apply refl_equal.
    * intros v1 lv1 Hvc1; rewrite Hvc1 in H; discriminate H.
  + case_eq (Cursor.next (outer c)); intros r1 c1' Hnc1; rewrite Hnc1 in H.
    destruct r1 as [e1 | | ]; try discriminate H.
    * case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
      destruct r2 as [e2 | | ]; try discriminate H.
      {
        case_eq (Cursor.visited (outer c)).
        - intro Hvc1; rewrite Hvc1 in Hc.
          rewrite (proj1 Hc).
          assert (H2 : comparelA (Oeset.compare O2) (Cursor.collection (inner c))
                                 (rev (Cursor.visited (inner c))) = Eq).
          {
            apply (Cursor.has_next_spec Hc2).
            intro H2.
            rewrite Cursor.has_next_next_neg, Hnc2 in H2.
            - apply H2; apply refl_equal.
            - apply Hc2.
          }
          rewrite (proj2 Hc) in H2.
          destruct (Cursor.collection (inner c)); [ | discriminate H2].
          simpl; rewrite flat_map_nil; [ | intros; apply refl_equal].
          apply refl_equal.
        - intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
          assert (H2 : comparelA (Oeset.compare O2) (Cursor.collection (Cursor.reset (inner c)))
                                 (rev (Cursor.visited (Cursor.reset (inner c)))) = Eq).
          {
            apply Cursor.has_next_spec.
            - apply Cursor.reset_coherent.
            - intro H2; rewrite Cursor.has_next_next_neg, Hnc2' in H2.
              + apply H2; apply refl_equal.
              + apply Cursor.reset_coherent.
          }
          rewrite Cursor.reset_visited, (Cursor.reset_collection (inner c)) in H2.
          assert (K2 : comparelA (Oeset.compare O2) (Cursor.collection (inner c))
                                 (rev (Cursor.visited (inner c))) = Eq).
          {
            apply (Cursor.has_next_spec Hc2).
            intro K2; rewrite Cursor.has_next_next_neg, Hnc2 in K2.
            - apply K2; apply refl_equal.
            - apply Hc2.
          }
          destruct (Cursor.collection (inner c)); [ | discriminate H2].
          destruct (Cursor.visited (inner c)) as [ | v2 lv2].
          + simpl in Hc; rewrite flat_map_nil in Hc; [ | intros; apply refl_equal].
            destruct (visited c) as [ | v lv]; [ | discriminate Hc].
            simpl; rewrite flat_map_nil; [ | intros; apply refl_equal].
            apply refl_equal.
          + simpl in K2; destruct (rev lv2); discriminate K2.
      }
    * case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2'' Hnc2'; rewrite Hnc2' in H.
      destruct r2; try discriminate H.
      assert (H2 : Cursor.collection (inner c) = nil).
      {
        rewrite <-  (Cursor.reset_collection (inner c)).
        apply Cursor.visited_nil_next_empty.
        - apply Cursor.reset_coherent.
        - apply Cursor.reset_visited.
        - rewrite Hnc2'; trivial.
      }
      rewrite H2, flat_map_nil; [ | intros; trivial].
      rewrite H2, (Cursor.empty_collection _ _ Hc2 H2) in Hc; simpl in Hc.
      {
        case_eq (Cursor.visited (outer c)).
        - intro Hvc1; rewrite Hvc1 in Hc.
          rewrite (proj1 Hc); trivial.
        - intros v1 lv1 Hvc1; rewrite Hvc1, flat_map_nil in Hc; [ | intros; trivial].
          destruct (visited c); [trivial | discriminate Hc].
      }
    * assert (K1 : comparelA (Oeset.compare O1) (Cursor.collection (outer c))
                                 (rev (Cursor.visited (outer c))) = Eq).
      {
        apply (Cursor.has_next_spec Hc1).
        intro K1; rewrite Cursor.has_next_next_neg, Hnc1 in K1.
        - apply K1; apply refl_equal.
        - apply Hc1.
      }
      {
        case_eq (Cursor.visited (outer c)).
        - intro Hvc1; rewrite Hvc1 in Hc.
          rewrite (proj1 Hc).
          rewrite Hvc1 in K1.
          destruct (Cursor.collection (outer c)); [ | discriminate K1].
          apply refl_equal.
        - intros v1 lv1 Hvc1; rewrite Hvc1 in Hc.
          generalize (comparelA_rev_eq _ _ _ Hc); clear Hc; intro Hc.
          rewrite comparelA_lt_gt; [ | intros; apply Oeset.compare_lt_gt].
          rewrite CompOpp_iff.
          refine (comparelA_eq_trans _ _ _ _ _ Hc _);
            [do 6 intro; apply Oeset.compare_eq_trans | ].
          simpl; rewrite rev_app_distr, <- app_nil_end, <- map_rev.
          rewrite Hvc1 in K1; simpl in K1.
          assert (K2 : comparelA (Oeset.compare O2) (Cursor.collection (inner c))
                                 (rev (Cursor.visited (inner c))) = Eq).
          {
            apply (Cursor.has_next_spec Hc2).
            intro K2; rewrite Cursor.has_next_next_neg, Hnc2 in K2.
            - apply K2; apply refl_equal.
            - apply Hc2.
          }
          rewrite comparelA_lt_gt, CompOpp_iff; [ | intros; apply Oeset.compare_lt_gt].
          refine (comparelA_eq_trans _ _ _ _ _ (cross_eq _ _ _ _ K1 K2) _);
            [do 6 intro; apply Oeset.compare_eq_trans | ].
          rewrite flat_map_app; apply comparelA_eq_app.
          + revert K2; set (l2 := rev (Cursor.visited (inner c))); clearbody l2.
            set (m2 := Cursor.collection (inner c)); clearbody m2.
            revert l2 m2; generalize lv1; intro l1;
              induction l1 as [ | a1 l1]; intros l2 m2 H2; [apply refl_equal | ].
            simpl.
            rewrite flat_map_app, rev_app_distr.
            apply comparelA_eq_app; [apply IHl1; assumption | ].
            rewrite map_rev, rev_involutive; simpl; rewrite <- app_nil_end.
            apply map_build_eq; [apply Oeset.compare_eq_refl | ].
            rewrite comparelA_lt_gt, H2; [trivial | ].
            intros; apply Oeset.compare_lt_gt.
          + simpl; rewrite <- app_nil_end.
            apply comparelA_eq_refl.
            intros; apply Oeset.compare_eq_refl.
      }
Qed.

Lemma has_next_next_neg:
  forall c, coherent c -> (has_next c <-> fst (next c) <> Empty_Cursor).
Proof.
intros c Hc.
unfold has_next; split; exact (fun h => h).
Qed.

Definition empty_cursor : cursor :=
    mk_cursor nil (Cursor.empty_cursor C1) (Cursor.empty_cursor C2).

Lemma empty_cursor_collection : collection empty_cursor = nil.
Proof.
unfold collection, empty_cursor; simpl.
now rewrite (Cursor.empty_cursor_collection C1).
Qed.

Lemma empty_cursor_coherent : coherent empty_cursor.
Proof.
unfold coherent, empty_cursor; simpl.
split; [apply Cursor.empty_cursor_coherent | ].
split; [apply Cursor.empty_cursor_coherent | ].
rewrite Cursor.empty_cursor_collection, 2 Cursor.empty_collection.
- split; trivial.
- apply Cursor.empty_cursor_coherent.
- apply Cursor.empty_cursor_collection.
- apply Cursor.empty_cursor_coherent.
- apply Cursor.empty_cursor_collection.
Qed.

Lemma empty_cursor_has_next : ~ has_next empty_cursor.
Proof.
unfold has_next, next, empty_cursor; simpl.
assert (H2 := Cursor.empty_cursor_has_next C2).
rewrite Cursor.has_next_next_neg in H2.
case_eq (Cursor.next (Cursor.empty_cursor C2)); intros r2 c2' Hnc2; rewrite Hnc2 in H2.
destruct r2 as [e2 | | ].
- apply False_rec; apply H2; discriminate.
- apply False_rec; apply H2; discriminate.
- assert (H1 := Cursor.empty_cursor_has_next C1).
  rewrite Cursor.has_next_next_neg in H1.
  case_eq (Cursor.next (Cursor.empty_cursor C1)); intros r1 c1' Hnc1; rewrite Hnc1 in H1.
  destruct r1 as [e1 | | ].
  + apply False_rec; apply H1; discriminate.
  + apply False_rec; apply H1; discriminate.
  + intro H; apply H; trivial.
  + apply Cursor.empty_cursor_coherent.
- apply Cursor.empty_cursor_coherent.
Qed.

 Lemma coherent_iter res :
  forall n c (f:o -> res -> res) acc, coherent c -> coherent (fst (iter next n c f acc)).
Proof.
intro n; induction n as [ | n]; intros c f acc Hc; simpl; [assumption | ].
assert (IH := IHn c f acc Hc).
case_eq (iter next n c f acc); intros c' l H; rewrite H in IH; simpl in IH.
assert (K := next_coherent IH).
case_eq (next c'); intros r c'' Hc'; rewrite Hc' in K; apply K.
Qed.

Definition ubound c :=
 Cursor.ubound (inner c) + (Cursor.ubound (outer c) * (S (Cursor.ubound (Cursor.reset (inner c))))).

Lemma reset_next : forall c : cursor, coherent c -> reset (snd (next c)) = reset c.
Proof.
intros c Hc; unfold coherent in Hc; unfold next, reset, ubound; simpl.
destruct Hc as [Hc1 [Hc2 Hc]].
case_eq (Cursor.next (inner c)); intros r2 c2 Hnc2.
destruct r2 as [e2 | | ]; simpl.
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1.
    case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
    destruct r1 as [e1 | | ]; simpl.
    * replace c1 with (snd (Result e1, c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [ | assumption].
      replace c2 with (snd (Result e2, c2)); [ | apply refl_equal].
      rewrite <- Hnc2, Cursor.next_reset; [ | assumption].
      trivial.
    * replace c1 with (snd (No_Result (A := o1), c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [ | assumption].
      apply refl_equal.
    * replace c1 with (snd (Empty_Cursor (A := o1), c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [ | assumption].
      apply refl_equal.
  + intros v1 lv1 Hvc1; simpl.
    replace c2 with (snd (Result e2, c2)); [ | apply refl_equal].
    rewrite <- Hnc2, Cursor.next_reset; [ | assumption].
    trivial.
- replace c2 with (snd (No_Result (A := o2), c2)); [ | apply refl_equal].
  rewrite <- Hnc2, Cursor.next_reset; [ | assumption].
  apply refl_equal.
- case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
  destruct r1 as [e1 | | ]; simpl.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
    destruct r2 as [e2 | | ]; simpl.
    * replace c1 with (snd (Result e1, c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [ | assumption].
      replace c2' with (snd (Result e2, c2')); [ | apply refl_equal].
      rewrite <- Hnc2', Cursor.next_reset, Cursor.reset_reset;[ | apply Cursor.reset_coherent].
      apply refl_equal.
    * replace c1 with (snd (Result e1, c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [ | assumption].
      replace c2' with (snd (No_Result (A := o2), c2')); [ | apply refl_equal].
      rewrite <- Hnc2', Cursor.next_reset, Cursor.reset_reset; [ | apply Cursor.reset_coherent].
      apply refl_equal.
    * replace c1 with (snd (Result e1, c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [ | assumption].
      replace c2' with (snd (Empty_Cursor (A := o2), c2')); [ | apply refl_equal].
      rewrite <- Hnc2', Cursor.next_reset, Cursor.reset_reset; [ | apply Cursor.reset_coherent].
      apply refl_equal.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
    assert (H1 : Cursor.reset c1 = Cursor.reset (outer c)).
    {
      replace c1 with (snd (No_Result (A := o1), c1)); [ | apply refl_equal].
      rewrite <- Hnc1, Cursor.next_reset; [trivial | assumption].
    }
    assert (H2 : Cursor.reset c2 = Cursor.reset (inner c)).
    {
      replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | apply refl_equal].
      rewrite <- Hnc2, Cursor.next_reset; [trivial | assumption].
    }
    destruct r2 as [e2 | | ]; simpl; rewrite H1, H2; apply refl_equal.
  + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | apply refl_equal].
    rewrite <- Hnc2, Cursor.next_reset; [ | assumption].
    apply refl_equal.
Qed.

Lemma reset_reset : forall c, reset (reset c) = reset c.
Proof.
intro c; unfold reset, ubound; simpl.
rewrite 2 Cursor.reset_reset.
 apply refl_equal.
Qed.

Lemma ubound_next_Empty :
  forall c, coherent c -> fst (next c) = Empty_Cursor -> ubound (snd (next c)) <= ubound c.
Proof.
intros c Hc; destruct Hc as [Hc1 [Hc2 Hc]].
unfold next, ubound.
case_eq (Cursor.next (inner c)); intros r2 c2 Hnc2.
destruct r2 as [e2 | | ].
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in Hc.
    case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
    destruct r1 as [e1 | | ].
    * intro Abs; discriminate Abs.
    * intro Abs; discriminate Abs.
    * intros _; simpl.
      {
        apply Plus.plus_le_compat_l.
        apply PeanoNat.Nat.mul_le_mono_nonneg_r.
        - apply le_0_n.
        - replace c1 with (snd (Empty_Cursor (A := o1), c1)); [ | trivial].
          rewrite <- Hnc1; apply Cursor.ubound_next_Empty; [assumption | ].
          rewrite Hnc1; trivial.
      }
  + intros v1 lv1 Hvc1 Abs; discriminate Abs.
- intro Abs; discriminate Abs.
- case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
  destruct r1 as [e1 | | ]; simpl.
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
    destruct r2 as [e2 | | ].
    * intro Abs; discriminate Abs.
    * intro Abs; discriminate Abs.
    * intros _; simpl.
      {
        apply Le.le_trans with (Cursor.ubound (outer c) * S (Cursor.ubound (Cursor.reset (inner c)))).
        - apply Le.le_trans with (S (Cursor.ubound c1) * S (Cursor.ubound (Cursor.reset (inner c)))).
          + simpl. replace (S
    (Cursor.ubound (Cursor.reset (inner c)) +
     Cursor.ubound c1 * S (Cursor.ubound (Cursor.reset (inner c))))) with
    (Cursor.ubound (Cursor.reset (inner c)) +
     (S (Cursor.ubound c1 * S (Cursor.ubound (Cursor.reset (inner c)))))) by lia.
            apply Plus.plus_le_compat.
            * replace c2' with (snd (Empty_Cursor (A := o2), c2')); [ | trivial].
              rewrite <- Hnc2'; apply Cursor.ubound_next_Empty; [apply Cursor.reset_coherent | ].
              rewrite Hnc2'; trivial.
            * replace c2' with (snd (Empty_Cursor (A := o2), c2')); [ | trivial].
              rewrite <- Hnc2', Cursor.next_reset, Cursor.reset_reset.
              lia.
              apply Cursor.reset_coherent.
          + apply PeanoNat.Nat.mul_le_mono_nonneg_r.
            * apply le_0_n.
            * replace c1 with (snd (Result e1, c1)); [ | trivial].
              rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
              rewrite Hnc1; discriminate.
        - apply Plus.le_plus_r.
      }
  + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
    destruct r2 as [e2 | | ]; try discriminate.
    intros _; simpl.
    apply Plus.plus_le_compat.
    * replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
      rewrite <- Hnc2, Cursor.ubound_next_Empty; [apply le_n | assumption | ].
      rewrite Hnc2; trivial.
    * {
        apply PeanoNat.Nat.mul_le_mono_nonneg.
        - apply le_0_n.
        - replace c1 with (snd (No_Result (A := o1), c1)); [ | trivial].
          rewrite <- Hnc1; apply Lt.lt_le_weak; apply Cursor.ubound_next_not_Empty; [assumption | ].
          rewrite Hnc1; discriminate.
        - apply le_0_n.
        - replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
          rewrite <- Hnc2, Cursor.next_reset; [apply le_n | assumption].
      }
  + intros _; apply Plus.plus_le_compat.
    * replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
      rewrite <- Hnc2, Cursor.ubound_next_Empty; [apply le_n | assumption | ].
      rewrite Hnc2; trivial.
    * apply PeanoNat.Nat.mul_le_mono_nonneg_l; [apply le_0_n | ].
      replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
      rewrite <- Hnc2, Cursor.next_reset; [apply le_n | trivial].
Qed.

Lemma ubound_next_not_Empty :
  forall c, coherent c -> fst (next c) <> Empty_Cursor -> ubound (snd (next c)) < ubound c.
Proof.
intros c Hc; destruct Hc as [Hc1 [Hc2 Hc]].
unfold next, ubound.
case_eq (Cursor.next (inner c)); intros r2 c2 Hnc2.
destruct r2 as [e2 | | ].
- assert (Hb2 : Cursor.ubound (snd (Cursor.next (inner c))) < Cursor.ubound (inner c)).
  {
    apply (Cursor.ubound_next_not_Empty _ _ Hc2).
    rewrite Hnc2; discriminate.
  }
  rewrite Hnc2 in Hb2; simpl in Hb2.
  case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in Hc.
    case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
    destruct r1 as [e1 | | ].
    * simpl; intros _.
      {
        apply Plus.plus_lt_le_compat; [assumption | ].
        replace c2 with (snd (Result e2, c2)); [ | trivial].
        rewrite <- Hnc2, Cursor.next_reset; trivial.
        apply Mult.mult_le_compat_r.
        replace c1 with (snd (Result e1, c1)); [ | trivial].
        rewrite <- Hnc1.
        apply Lt.lt_le_weak; apply (Cursor.ubound_next_not_Empty _ _ Hc1).
        rewrite Hnc1; discriminate.
      }
    * simpl; intros _.
      {
        apply Plus.plus_le_lt_compat; [apply le_n | ].
        apply Mult.mult_lt_compat_r.
        - replace c1 with (snd (No_Result (A := o1), c1)); [ | trivial].
          rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
          rewrite Hnc1; discriminate.
        - lia.
      }
    *  intro Abs; apply False_rec; apply Abs; apply refl_equal.
  + intros v1 lv1 Hcv1 _; simpl.
    apply Plus.plus_lt_le_compat; [apply Hb2 | ].
    replace c2 with (snd (Result e2, c2)); [ | trivial].
    rewrite <- Hnc2, Cursor.next_reset; [apply le_n | trivial].
- assert (Hb2 : Cursor.ubound (snd (Cursor.next (inner c))) < Cursor.ubound (inner c)).
  {
    apply (Cursor.ubound_next_not_Empty _ _ Hc2).
    rewrite Hnc2; discriminate.
  }
  rewrite Hnc2 in Hb2; simpl in Hb2.
  intros _; simpl.
  apply Plus.plus_lt_le_compat; [assumption | ].
  apply Mult.mult_le_compat_l.
  replace c2 with (snd (No_Result (A := o2), c2)); [ | trivial].
  rewrite <- Hnc2, Cursor.next_reset; trivial.
- case_eq (Cursor.visited (outer c)).
  + intro Hvc1; rewrite Hvc1 in Hc.
    case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
    destruct r1 as [e1 | | ].
    * case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
      {
        destruct r2 as [e2 | | ].
        - simpl; intros _.
          apply Lt.lt_le_trans with (Cursor.ubound (outer c) * (S (Cursor.ubound (Cursor.reset (inner c))))).
          + apply Lt.lt_le_trans with
                (Cursor.ubound (Cursor.reset (inner c)) + Cursor.ubound c1 * (S (Cursor.ubound (Cursor.reset c2')))).
            * apply Plus.plus_lt_compat_r.
              replace c2' with (snd (Result e2, c2')); [ | trivial].
              rewrite <- Hnc2'.
              apply Cursor.ubound_next_not_Empty; [apply Cursor.reset_coherent | ].
              rewrite Hnc2'; discriminate.
            * replace c2' with (snd (Result e2, c2')); [ | trivial].
              rewrite <- Hnc2', Cursor.next_reset, Cursor.reset_reset;
                [ | apply Cursor.reset_coherent].
              apply Le.le_trans with (S (Cursor.ubound c1) * (S (Cursor.ubound (Cursor.reset (inner c)))));
                [simpl; lia | ].
              apply Mult.mult_le_compat_r.
              replace c1 with (snd (Result e1, c1)); [ | trivial].
              rewrite <- Hnc1.
              apply (Cursor.ubound_next_not_Empty _ _ Hc1).
              rewrite Hnc1; discriminate.
          + apply Plus.le_plus_r.
        - simpl; intros _.
          apply Lt.lt_le_trans with (Cursor.ubound (outer c) * (S (Cursor.ubound (Cursor.reset (inner c))))).
          + apply Lt.lt_le_trans with
                (Cursor.ubound (Cursor.reset (inner c)) + Cursor.ubound c1 * (S (Cursor.ubound (Cursor.reset c2')))).
            * apply Plus.plus_lt_compat_r.
              replace c2' with (snd (No_Result (A := o2), c2')); [ | trivial].
              rewrite <- Hnc2'.
              apply Cursor.ubound_next_not_Empty; [apply Cursor.reset_coherent | ].
              rewrite Hnc2'; discriminate.
            * replace c2' with (snd (No_Result (A := o2), c2')); [ | trivial].
              rewrite <- Hnc2', Cursor.next_reset, Cursor.reset_reset;
                [ | apply Cursor.reset_coherent].
              apply Le.le_trans with (S (Cursor.ubound c1) * (S (Cursor.ubound (Cursor.reset (inner c)))));
                [simpl; lia | ].
              apply Mult.mult_le_compat_r.
              replace c1 with (snd (Result e1, c1)); [ | trivial].
              rewrite <- Hnc1.
              apply (Cursor.ubound_next_not_Empty _ _ Hc1).
              rewrite Hnc1; discriminate.
          + apply Plus.le_plus_r.
        - intro Abs; apply False_rec; apply Abs; apply refl_equal.
      }
    * case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
      {
        destruct r2 as [e2 | | ].
        - simpl; intros _.
          apply Plus.plus_le_lt_compat.
          + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
            rewrite <- Hnc2; apply Cursor.ubound_next_Empty; trivial.
            rewrite Hnc2; trivial.
          + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
            rewrite <- Hnc2, Cursor.next_reset; trivial.
            apply Mult.mult_lt_compat_r.
            * replace c1 with (snd (No_Result (A := o1), c1)); [ | trivial].
              rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
              rewrite Hnc1; discriminate.
            * lia.
        - simpl; intros _.
          apply Plus.plus_le_lt_compat.
          + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
            rewrite <- Hnc2; apply Cursor.ubound_next_Empty; trivial.
            rewrite Hnc2; trivial.
          + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
            rewrite <- Hnc2, Cursor.next_reset; trivial.
            apply Mult.mult_lt_compat_r.
            * replace c1 with (snd (No_Result (A := o1), c1)); [ | trivial].
              rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
              rewrite Hnc1; discriminate.
            * lia.
        - intro Abs; apply False_rec; apply Abs; apply refl_equal.
      }
    * intro Abs; apply False_rec; apply Abs; apply refl_equal.
  + intros v1 lv1 Hcv1 H; simpl.
    case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
    destruct r1 as [e1 | | ].
    * {
        case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'.
        assert (H2 : Cursor.ubound (Cursor.reset c2') = Cursor.ubound (Cursor.reset (inner c))).
        {
          replace c2' with (snd (r2, c2')); [ | trivial].
          rewrite <- Hnc2'.
          rewrite Cursor.next_reset, Cursor.reset_reset; trivial.
          apply Cursor.reset_coherent.
        }
        destruct r2 as [e2 | | ].
        - simpl.
          apply Lt.lt_le_trans with  (Cursor.ubound (outer c) * (S (Cursor.ubound (Cursor.reset (inner c))))).
          + rewrite H2.
            apply Lt.lt_le_trans with (Cursor.ubound (Cursor.reset (inner c)) +
                                        Cursor.ubound c1 * (S (Cursor.ubound (Cursor.reset (inner c))))).
            * apply Plus.plus_lt_le_compat; [ | apply le_n].
              replace c2' with (snd (Result e2, c2')); [ | trivial].
              rewrite <- Hnc2'.
              apply Cursor.ubound_next_not_Empty; [apply Cursor.reset_coherent | ].
              rewrite Hnc2'; discriminate.
            * apply Le.le_trans with (S (Cursor.ubound c1) * (S (Cursor.ubound (Cursor.reset (inner c)))));
                 [simpl; lia | ].
               apply Mult.mult_le_compat_r.
               replace c1 with (snd (Result e1, c1)); [ | trivial].
               rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
               rewrite Hnc1; discriminate.
          + apply Plus.le_plus_r.
        - simpl.
          apply Lt.lt_le_trans with  (Cursor.ubound (outer c) * (S (Cursor.ubound (Cursor.reset (inner c))))).
          + rewrite H2.
            apply Lt.lt_le_trans with (Cursor.ubound (Cursor.reset (inner c)) +
                                        Cursor.ubound c1 * (S (Cursor.ubound (Cursor.reset (inner c))))).
            * apply Plus.plus_lt_le_compat; [ | lia].
              replace c2' with (snd (No_Result (A := o2), c2')); [ | trivial].
              rewrite <- Hnc2'.
              apply Cursor.ubound_next_not_Empty; [apply Cursor.reset_coherent | ].
              rewrite Hnc2'; discriminate.
            * apply Le.le_trans with (S (Cursor.ubound c1) * (S (Cursor.ubound (Cursor.reset (inner c)))));
                 [simpl; lia | ].
               apply Mult.mult_le_compat_r.
               replace c1 with (snd (Result e1, c1)); [ | trivial].
               rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
               rewrite Hnc1; discriminate.
          + apply Plus.le_plus_r.
        - rewrite Hnc1, Hnc2' in H; apply False_rec; apply H; apply refl_equal.
      }
    * rewrite Hnc1 in H.
      case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'; rewrite Hnc2' in H.
      assert (H2 : Cursor.ubound (Cursor.reset c2) = Cursor.ubound (Cursor.reset (inner c))).
      {
        replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
        rewrite <- Hnc2.
        rewrite Cursor.next_reset; trivial.
      }
      {
        destruct r2 as [e2 | | ].
        - simpl.
          apply Plus.plus_le_lt_compat.
          + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
            rewrite <- Hnc2; apply Cursor.ubound_next_Empty; [assumption | ].
            rewrite Hnc2; trivial.
          + rewrite H2.
            apply Mult.mult_lt_compat_r.
            * replace c1 with (snd (No_Result (A := o1), c1)); [ | trivial].
              rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
              rewrite Hnc1; discriminate.
            * lia.
        - simpl.
          apply Plus.plus_le_lt_compat.
          + replace c2 with (snd (Empty_Cursor (A := o2), c2)); [ | trivial].
            rewrite <- Hnc2; apply Cursor.ubound_next_Empty; [assumption | ].
            rewrite Hnc2; trivial.
          + rewrite H2.
            apply Mult.mult_lt_compat_r.
            * replace c1 with (snd (No_Result (A := o1), c1)); [ | trivial].
              rewrite <- Hnc1; apply Cursor.ubound_next_not_Empty; [assumption | ].
              rewrite Hnc1; discriminate.
            * lia.
        - apply False_rec; apply H; apply refl_equal.
      }
    * rewrite Hnc1 in H.
      apply False_rec; apply H; apply refl_equal.
Qed.

(*
Lemma ubound_reset :
  forall c, coherent c -> ubound c <= ubound (reset c).
Proof.
intros c Hc; unfold coherent in Hc; destruct Hc as [Hc1 [Hc2 Hc]].
unfold ubound.
apply Plus.plus_le_compat.
- apply Cursor.ubound_reset; assumption.
- apply Mult.mult_le_compat.
  + apply Cursor.ubound_reset; assumption.
  + apply Cursor.ubound_reset; apply Cursor.reset_coherent.
Qed.
*)

Lemma ubound_complete res :
forall (c : cursor) (f : o -> res -> res) (acc : res),
  coherent c -> forall p : nat, ubound c <= p -> ~ has_next (fst (iter next p c f acc)).
Proof.
intros c f acc Hc p Hp.
rewrite has_next_next_neg; [ | apply coherent_iter; assumption].
intro H; elim H; clear H.
{
  (* rewrite (fst_iter_eq next p c f acc cons (visited c)). *)
  revert c Hp Hc acc; induction p as [ | n];
    intros c Hn Hc acc.
  - simpl in Hc; destruct Hc as [Hc1 [Hc2 Hc]].
    unfold next; unfold ubound in Hn; simpl.
    case_eq (Cursor.ubound (inner c)).
    + intro H2; rewrite H2 in Hn; simpl in Hn.
      assert (K2 : ~ Cursor.has_next (fst (iter Cursor.next 0 (inner c) cons nil))).
      {
        apply (Cursor.ubound_complete (c := inner c) cons nil Hc2 0).
        rewrite H2; apply le_n.
      }
      simpl in K2; rewrite Cursor.has_next_next in K2; [ | assumption].
      case_eq (Cursor.next (inner c)); intros r2 c2 Hnc2; rewrite Hnc2 in K2; simpl in K2; subst r2.
      case_eq (Cursor.ubound (outer c)).
      * intro H1.
        assert (K1 : ~ Cursor.has_next (fst (iter Cursor.next 0 (outer c) cons nil))).
        {
          apply (Cursor.ubound_complete (c := outer c) cons nil Hc1 0).
          rewrite H1; apply le_n.
        }
        simpl in K1; rewrite Cursor.has_next_next in K1; [ | assumption].
        case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1; rewrite Hnc1 in K1; simpl in K1; subst r1.
        apply refl_equal.
      * intros n1 H1; rewrite H1 in Hn.
        {
          case_eq (Cursor.ubound (Cursor.reset (inner c))).
          - intro H2'.
            assert (K2' : ~ Cursor.has_next (fst (iter Cursor.next 0 (Cursor.reset (inner c))
                                                       cons nil))).
            {
              apply (Cursor.ubound_complete (c := Cursor.reset (inner c))
                                            cons nil
                                            (Cursor.reset_coherent _) 0).
              rewrite H2'; apply le_n.
            }
            simpl in K2'; rewrite Cursor.has_next_next in K2'; [ | apply Cursor.reset_coherent].
            case_eq (Cursor.next (outer c)); intros r1 c1 Hnc1.
            destruct r1 as [e1 | | ].
            + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'; rewrite Hnc2' in K2'.
              simpl in K2'; subst r2.
              apply refl_equal.
            + case_eq (Cursor.next (Cursor.reset (inner c))); intros r2 c2' Hnc2'; rewrite Hnc2' in K2'.
              simpl in K2'; subst r2.
              apply refl_equal.
            + apply refl_equal.
          - intros n2' H2'; rewrite H2' in Hn; simpl in Hn; inversion Hn.
        }
    + intros n2 H2; rewrite H2 in Hn; simpl in Hn; inversion Hn.
  - case_eq (next c); intros r c' Hnc; destruct r as [e | | ].
    + assert (Aux : ubound (snd (next c)) < ubound c).
      {
        apply (ubound_next_not_Empty Hc); rewrite Hnc; discriminate.
      }
      rewrite Hnc in Aux; simpl in Aux.
      replace (S n) with (n + 1); [ | rewrite PeanoNat.Nat.add_comm; trivial].
      unfold iter; rewrite nat_iter_plus; simpl Nat.iter at 2; rewrite Hnc.
      assert (IH : fst (next (fst (iter next n c' f (f e acc)))) = Empty_Cursor).
      {
        apply (IHn c').
        - apply le_S_n.
          refine (Le.le_trans _ _ _ Aux Hn).
        - generalize (next_coherent Hc); rewrite Hnc; exact (fun h => h).
      }
      unfold iter in IH; rewrite IH; trivial.
    + assert (Aux : ubound (snd (next c)) < ubound c).
      {
        apply (ubound_next_not_Empty Hc); rewrite Hnc; discriminate.
      }
      rewrite Hnc in Aux; simpl in Aux.
      replace (S n) with (n + 1); [ | rewrite PeanoNat.Nat.add_comm; trivial].
      unfold iter; rewrite nat_iter_plus; simpl Nat.iter at 2; rewrite Hnc.
      assert (IH : fst (next (fst (iter next n c' f acc))) = Empty_Cursor).
      {
        apply (IHn c').
        - apply le_S_n.
          refine (Le.le_trans _ _ _ Aux Hn).
        - generalize (next_coherent Hc); rewrite Hnc; exact (fun h => h).
      }
      unfold iter in IH; rewrite IH; trivial.
    + apply (iter_Empty_Cursor coherent _ next_coherent next_Empty_Cursor _ _ _ _ Hc).
      rewrite Hnc; trivial.
}
Qed.

Definition build : Cursor.Rcd O.
apply (Cursor.mk_R O collection visited coherent)
  with reset next has_next empty_cursor ubound.
- apply visited_collection.
- apply reset_collection.
- apply reset_visited.
- apply reset_coherent.
- apply next_collection.
- apply next_visited_Result.
- apply next_visited_No_Result.
- apply next_visited_Empty_Cursor.
- apply next_coherent.
- apply next_Empty_Cursor.
- apply reset_next.
- apply has_next_spec.
- apply has_next_next_neg.
- apply empty_cursor_collection.
- apply empty_cursor_coherent.
- apply empty_cursor_has_next.
- apply reset_reset.
- apply ubound_next_Empty.
- apply ubound_next_not_Empty.
(* - apply ubound_reset. *)
- apply ubound_complete.
Defined.

End Sec.
End NestedLoop.


  Require Export XD.Integers2.

  Definition ZZnZ := { z : ZZ | z <> Zzero }.

  Definition _QPair := @Pair ZZ ZZnZ.

  Definition _Qfirst (p:_QPair) : ZZ := match p with
  | pair f _ => f
  end.

  Definition _Qsecond (p:_QPair) : ZZ := match p with
  | pair _ (exist _ s _) => s
  end.

  Definition _Qrel (x y:_QPair) :=
    Zmult (_Qfirst x) (_Qsecond y) = Zmult (_Qsecond x) (_Qfirst y).

  Theorem _Qrel_equivalence : equivalence _Qrel.
  Proof.
    red.
    split.
    {
      red.
      intros (xf,(xs,hx)).
      red.
      simpl.
      rewrite Zmult_comm.
      reflexivity.
    }
    split.
    {
      red.
      intros (xf,(xs,hx)) (yf,(ys,hy)).
      intro h.
      red.
      red in h.
      simpl in *.
      rewrite (Zmult_comm yf).
      rewrite (Zmult_comm ys).
      symmetry.
      exact h.
    }
    {
      red.
      intros (xf,(xs,hx)) (yf,(ys,hy)) (zf,(zs,hz)) hxy hyz.
      red. red in hxy,hyz.
      simpl in *.
      apply Zmult_elim_l with ys. exact hy.
      rewrite <- Zmult_assoc.
      rewrite (Zmult_comm ys).
      rewrite hxy.
      rewrite Zmult_assoc.
      rewrite hyz.
      rewrite <- Zmult_assoc.
      rewrite (Zmult_comm xs).
      rewrite Zmult_assoc.
      apply Zmult_intro_l.
      reflexivity.
    }
  Qed.

  Definition Zdivides (d x:ZZ) := exists d' : ZZ, Zmult d d' = x.

  Definition Zcoprime (x y:ZZ) := forall d:ZZ, Zdivides d x -> Zdivides d y -> d = Zone.

  (* TODO *)
  Definition _Qcond (p:_QPair) := Zcoprime (_Qfirst p) (_Qsecond p).

  Definition QQ := { p : _QPair | _Qcond p }.

  Lemma _Q_representation : forall (p:_QPair), exists (q:QQ), _Qrel p (proj1_sig q).
  Proof.
    intros (pf,(ps,hps)).
    assert (h:_Qcond p).
    red. trivial.
    exists (exist _ p h).
    red.
    simpl.
    rewrite Zmult_comm.
    reflexivity.
  Qed.

  Lemma _Q_uniqueness : forall (x y:QQ),
    let xp := proj1_sig x in
    let yp := proj1_sig y in
    _Qrel xp yp -> xp = yp.
  Proof.
    intros ((xf,(xs,hxs)),hx) ((yf,(ys,hys)),hy).
    simpl.
    intro h.
    red in hx, hy.
    clear hx hy.
    red in h.
    simpl in h.
    f_equal.
    admit.
    apply proof_irrelevance.
    simpl.
    admit.
  Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable perp_at_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_inequalitysymmetric_1 : (forall A B : Universe, (A <> B -> B <> A)).
Variable proposition_23_2 : (forall A B C D E : Universe, (exists X Y : Universe, ((A <> B /\ ~(col_ D C E)) -> (out_ A B Y /\ congA_ X A Y D C E)))).
Variable lemma_raystrict_3 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable lemma_equalanglessymmetric_4 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglesNC_5 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_rayimpliescollinear_6 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_collinear4_7 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearorder_8 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable proposition_12_9 : (forall A B C : Universe, (exists X : Universe, ((A <> B /\ ~(col_ A B C)) -> perp_at_ C X A B X))).
Variable defperpat_10 : (forall P Q A B C : Universe, (exists X : Universe, (perp_at_ P Q A B C -> (col_ P Q C /\ (col_ A B C /\ (col_ A B X /\ per_ X C P)))))).
Variable defperpat2_11 : (forall P Q A B C X : Universe, ((col_ P Q C /\ (col_ A B C /\ (col_ A B X /\ per_ X C P))) -> perp_at_ P Q A B C)).
Variable lemma_rightangleNC_12 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable defcollinear_13 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_14 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_15 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_16 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_17 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_18 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_19 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_extension_20 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable lemma_betweennotequal_21 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinear5_22 : (forall A B C D E : Universe, ((A <> B /\ (col_ A B C /\ (col_ A B D /\ col_ A B E))) -> col_ C D E)).
Variable proposition_11B_23 : (forall A B C P : Universe, (exists X : Universe, ((betS_ A C B /\ ~(col_ A B P)) -> (per_ A C X /\ tS_ X A B P)))).
Variable lemma_layoff_24 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_angledistinct_25 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_8_3_26 : (forall A B C D : Universe, ((per_ A B C /\ out_ B C D) -> per_ A B D)).
Variable lemma_8_2_27 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_Euclid4_28 : (forall A B C Xa Xb Xc : Universe, ((per_ A B C /\ per_ Xa Xb Xc) -> congA_ A B C Xa Xb Xc)).
Variable lemma_collinearright_29 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_doublereverse_30 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_ABCequalsCBA_31 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_32 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_congruenceflip_33 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable cn_congruencereflexive_34 : (forall A B : Universe, cong_ A B A B).
Variable proposition_04_35 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable lemma_ray4_1_36 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_37 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_38 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable axiom_betweennesssymmetry_39 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_equalanglesreflexive_40 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalangleshelper_41 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable defsupplement_42 : (forall A B C D F : Universe, (supp_ A B C D F -> (out_ B C D /\ betS_ A B F))).
Variable defsupplement2_43 : (forall A B C D F : Universe, ((out_ B C D /\ betS_ A B F) -> supp_ A B C D F)).
Variable lemma_equalanglesflip_44 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable lemma_supplements_45 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((congA_ A B C Xa Xb Xc /\ (supp_ A B C D F /\ supp_ Xa Xb Xc Xd Xf)) -> congA_ D B F Xd Xb Xf)).
Variable lemma_ray5_46 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_9_5_47 : (forall A B C P Q R : Universe, ((tS_ P A B C /\ (out_ R Q P /\ col_ A B R)) -> tS_ Q A B C)).
Variable defoppositeside_48 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_49 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).

Theorem proposition_23B_50 : (forall A B C D E P : Universe, (exists X Y : Universe, ((A <> B /\ (~(col_ D C E) /\ ~(col_ A B P))) -> (out_ A B Y /\ (congA_ X A Y D C E /\ tS_ X A B P))))).
Proof.
  time tac.
Qed.

End FOFProblem.


Load "3_poly_exercises.v".

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Theorem rev_app_distr: forall X (l1 l2 : list X), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros x l1 l2.
  induction l1.
  - (* base *) simpl. rewrite app_nil_r. reflexivity.
  - (* i.h. *) simpl. rewrite IHl1. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X, rev (rev l) = l.
Proof.
  intros x l.
  induction l.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite rev_app_distr. rewrite IHl. simpl. reflexivity.
Qed.


Require Export Coq.Relations.Relations.
Require Export Coq.Classes.RelationPairs.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.Equivalence.
Require Import Logic.lib.Relation_ext.
Require Import Logic.lib.Bisimulation.

Instance eq_preorder (A: Type): PreOrder (@eq A) :=
  Build_PreOrder _ (eq_Reflexive) (eq_Transitive).

Instance RelProd_Preorder:
  forall {A B : Type} (RA: relation A) (RB : relation B),
  PreOrder RA -> PreOrder RB -> PreOrder (RelProd RA RB).
Proof.
  intros.
  destruct H, H0.
  constructor.
  + apply RelProd_Reflexive; auto.
  + apply RelProd_Transitive; auto.
Qed.

Instance RelProd_PartialFunctional:
  forall {A B : Type} (RA: relation A) (RB : relation B),
  PartialFunctional RA -> PartialFunctional RB -> PartialFunctional (RelProd RA RB).
Proof.
  intros; hnf; intros.
  destruct m as [m1 m2], n as [n1 n2], n' as [n1' n2'], H1, H2.
  hnf in H1, H2, H3, H4; simpl in *.
  f_equal.
  + eapply H; eauto.
  + eapply H0; eauto.
Qed.

Instance RelProd_Bisimulation:
  forall {A B : Type} (bisA RA: relation A) (bisB RB : relation B),
  Bisimulation bisA RA -> Bisimulation bisB RB -> Bisimulation (RelProd bisA bisB) (RelProd RA RB).
Proof.
  intros.
  constructor; intros [m1 m2] [n1 n2] [? ?].
  + intros [m1' m2'] [? ?].
    hnf in H1, H2, H3, H4; simpl in *.
    destruct (@bis_l _ _ _ H _ _ H1 _ H3) as [n1' [? ?]].
    destruct (@bis_l _ _ _ H0 _ _ H2 _ H4) as [n2' [? ?]].
    exists (n1', n2'); auto.
  + intros [n1' n2'] [? ?].
    hnf in H1, H2, H3, H4; simpl in *.
    destruct (@bis_r _ _ _ H _ _ H1 _ H3) as [m1' [? ?]].
    destruct (@bis_r _ _ _ H0 _ _ H2 _ H4) as [m2' [? ?]].
    exists (m1', m2'); auto.
Qed.

Instance RelProd_Inclusion:
  forall {A B : Type} (RA1 RA2: relation A) (RB1 RB2 : relation B),
  Inclusion RA1 RA2 -> Inclusion RB1 RB2 -> Inclusion (RelProd RA1 RB1) (RelProd RA2 RB2).
Proof.
  intros.
  hnf; intros.
  destruct H1; split.
  + eapply H; eauto.
  + eapply H0; eauto.
Qed.

Instance pointwise_preorder:
  forall A {B : Type} (RB : relation B),
  PreOrder RB -> PreOrder (pointwise_relation A RB).
Proof.
  intros.
  destruct H.
  constructor.
  + apply pointwise_reflexive; auto.
  + apply pointwise_transitive; auto.
Qed.

Inductive option00_relation {A: Type} (R: relation A): relation (option A):=
| None_None_option00: option00_relation R None None
| Some_Some_option00: forall a b, R a b -> option00_relation R (Some a) (Some b).

Inductive option01_relation {A: Type} (R: relation A): relation (option A):=
| None_None_option01: option01_relation R None None
| None_Some_option01: forall a, option01_relation R None (Some a)
| Some_Some_option01: forall a b, R a b -> option01_relation R (Some a) (Some b).

Instance option00_reflexive {A: Type} (R: relation A) {_: Reflexive R}: Reflexive (option00_relation R).
Proof.
  hnf; intros.
  destruct x.
  + constructor; reflexivity.
  + constructor.
Qed.

Instance option01_reflexive {A: Type} (R: relation A) {_: Reflexive R}: Reflexive (option01_relation R).
Proof.
  hnf; intros.
  destruct x.
  + constructor; reflexivity.
  + constructor.
Qed.

Instance option00_symmetric {A: Type} (R: relation A) {_: Symmetric R}: Symmetric (option00_relation R).
Proof.
  hnf; intros.
  inversion H0; subst.
  + constructor.
  + constructor.
    symmetry; auto.
Qed.

Instance option00_transitive {A: Type} (R: relation A) {_: Transitive R}: Transitive (option00_relation R).
Proof.
  hnf; intros.
  hnf; intros.
  inversion H0; inversion H1; subst; try first [congruence | constructor].
  inversion H6; subst.
  etransitivity; eauto.
Qed.

Instance option01_transitive {A: Type} (R: relation A) {_: Transitive R}: Transitive (option01_relation R).
Proof.
  hnf; intros.
  hnf; intros.
  inversion H0; inversion H1; subst; try first [congruence | constructor].
  inversion H6; subst.
  etransitivity; eauto.
Qed.

Instance option00_preorder {A: Type} (R: relation A) {_: PreOrder R}: PreOrder (option00_relation R)
  := Build_PreOrder _ (option00_reflexive R) (option00_transitive R).

Instance option01_preorder {A: Type} (R: relation A) {_: PreOrder R}: PreOrder (option01_relation R)
  := Build_PreOrder _ (option01_reflexive R) (option01_transitive R).

Instance option00_equiv {A: Type} (R: relation A) {_: Equivalence R}: Equivalence (option00_relation R)
  := Build_Equivalence _ (option00_reflexive R) (option00_symmetric R) (option00_transitive R).

Inductive sum00_relation {A B: Type} (RA: relation A) (RB: relation B): relation (A + B) :=
  | sum00_ll a1 a2: RA a1 a2 -> sum00_relation RA RB (inl a1) (inl a2)
  | sum00_rr b1 b2: RB b1 b2 -> sum00_relation RA RB (inr b1) (inr b2).

Inductive sum01_relation {A B: Type} (RA: relation A) (RB: relation B): relation (A + B) :=
  | sum01_ll a1 a2: RA a1 a2 -> sum01_relation RA RB (inl a1) (inl a2)
  | sum01_lr a b: sum01_relation RA RB (inl a) (inr b)
  | sum01_rr b1 b2: RB b1 b2 -> sum01_relation RA RB (inr b1) (inr b2).

Instance sum00_reflexive {A B: Type} (RA: relation A) (RB: relation B) {_: Reflexive RA} {_: Reflexive RB}: Reflexive (sum00_relation RA RB).
Proof.
  hnf; intros.
  destruct x; constructor; auto.
Qed.

Instance sum01_reflexive {A B: Type} (RA: relation A) (RB: relation B) {_: Reflexive RA} {_: Reflexive RB}: Reflexive (sum01_relation RA RB).
Proof.
  hnf; intros.
  destruct x; constructor; auto.
Qed.

Instance sum00_transitive {A B: Type} (RA: relation A) (RB: relation B) {_: Transitive RA} {_: Transitive RB}: Transitive (sum00_relation RA RB).
Proof.
  hnf; intros.
  inversion H1; subst; inversion H2; subst;
  constructor;
  etransitivity; eauto.
Qed.

Instance sum01_transitive {A B: Type} (RA: relation A) (RB: relation B) {_: Transitive RA} {_: Transitive RB}: Transitive (sum01_relation RA RB).
Proof.
  hnf; intros.
  inversion H1; subst; inversion H2; subst;
  constructor;
  etransitivity; eauto.
Qed.

Instance sum00_preorder {A B: Type} (RA: relation A) (RB: relation B) {_: PreOrder RA} {_: PreOrder RB}: PreOrder (sum00_relation RA RB) :=
  Build_PreOrder _ (sum00_reflexive RA RB) (sum00_transitive RA RB).

Instance sum01_preorder {A B: Type} (RA: relation A) (RB: relation B) {_: PreOrder RA} {_: PreOrder RB}: PreOrder (sum01_relation RA RB) :=
  Build_PreOrder _ (sum01_reflexive RA RB) (sum01_transitive RA RB).

Definition true_relation (A: Type): relation A := fun _ _ => True.

Instance true_reflexive (A: Type): Reflexive (true_relation A).
Proof.
  hnf; intros.
  hnf; auto.
Qed.

Instance true_transitive (A: Type): Transitive (true_relation A).
Proof.
  hnf; intros.
  hnf; auto.
Qed.

Instance true_preorder (A: Type): PreOrder (true_relation A) :=
  Build_PreOrder _ (true_reflexive A) (true_transitive A).


Require Import FMapInterface2.
Require Import FMapFacts2.
Require Import SetoidList.
Require Import Sumbool_dec.
(* The pattern on which this is built.

(* from SetoidList *)
Definition compat_P (P : A->Prop) := forall x y, eqA x y -> P x -> P y.

(* from FMapInterface *)
Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

(* from FMapBridge *)
Definition exists_ :
  forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
    {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
Proof.
  intros.
  generalize (exists_1 (s:=s) (f:=fdec Pdec))
    (exists_2 (s:=s) (f:=fdec Pdec)).
  case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ];
    intros.
  elim H0; auto; intros.
  exists x; intuition.
  generalize H4.
  unfold fdec in |- *.
  case (Pdec x); intuition.
  inversion H2.
  intuition.
  elim H2; intros.
  absurd (false = true); [ auto with bool | apply H; auto ].
  exists x; intuition.
  unfold fdec in |- *.
  case (Pdec x); intuition.
Qed.

*)

Module MakeExists_fun (E:OrderedType) (MapS: Sfun E) (Data:OrderedType) (M : Sord_fun E MapS Data).

  Definition Exists (P : MapS.key -> Data.t -> Prop) m :=
    exists k, exists e, MapS.MapsTo k e m /\ P k e.

  Definition Exists_1 (P : MapS.key * Data.t -> Prop) m :=
    exists p, InA (@MapS.eq_key_elt Data.t) p (MapS.elements m) /\ P p.

  Set Implicit Arguments.

    Definition compat_P2 (P : MapS.key->Data.t->Prop) := forall a a' b b',
       E.eq a a' -> Data.eq b b' -> P a b -> P a' b'.

    Definition pair_fn (P : MapS.key -> Data.t->Prop) := (fun p => (P (fst p) (snd p))).

    Definition pair_eq p p':= E.eq (fst p) (fst p') /\ Data.eq (snd p) (snd p').

    Theorem compat_P2_pair: forall (P : MapS.key -> Data.t ->Prop),
      compat_P2 P
      <->
      compat_P pair_eq (pair_fn P).
    Proof.
      intros; split; intros; unfold compat_P in *; unfold compat_P2 in *.
      repeat progress red; intros.
      unfold pair_fn. destruct H0.
      apply (H (fst x) (fst y) (snd x) (snd y)); auto;
        rewrite H2; apply Data.eq_refl.
      intros. do 2 red in H. unfold pair_eq in H; unfold pair_fn in H.
      generalize (H (a,b) (a',b')); intros H'.
      unfold MapS.eq_key_elt in *; unfold pair_fn in *; unfold pair_eq in *.
      simpl in H'; intuition eauto.
    Qed.

  Unset Implicit Arguments.

  Module MOrdProps := FMapFacts2.OrdProperties_fun E MapS.
  Module MProps := MOrdProps.P.
  Module MFacts := MProps.F.

  Theorem pair_fn_dec:
      forall (P : MapS.key -> Data.t -> Prop) (Pdec : forall k e, {P k e} + {~ P k e}),
        forall p, {(pair_fn P) p} + {~ (pair_fn P) p}.
    Proof.
      intros.
      unfold pair_fn; simpl; apply Pdec.
    Qed.
    Implicit Arguments pair_fn_dec [P].

    (* exists_2 was used as a template for exists_1, I'm hanging on to it. *)

    Theorem exists_2:  forall (P : MapS.key * Data.t -> Prop)
      (Pdec : forall p, {P p} + {~ P p}) (m : M.t),
      compat_P pair_eq P ->
      {Exists_1 P m} + {~ Exists_1 P m}.
    Proof.
      intros.
      unfold Exists_1.
      unfold compat_P in *.
      induction (MapS.elements m).
      (* base *)
      right.
      intro Hex.
      destruct Hex as [p Hex]; destruct Hex as [Hex Hex'].
      inversion Hex.
      destruct IHl as [He|Hne].
      (* exists *)
      left.
      destruct He as [p Hex]; destruct Hex as [Hex Hex'].
      eapply ex_intro with p.
      split; auto.
      (* ~ exists *)
      (* either a is the pair we are looking for or not. *)
      case (Pdec a); intros Hp.
      (*  P a *)
      left; apply ex_intro with a; split; unfold MapS.eq_key_elt; auto.
      (* ~ P a *)
      right.
      intro Hex.
      destruct Hex as [p Hex]. destruct Hex as [Hex Hex'].
      inversion Hex.
      (* p = a *)
      unfold MapS.eq_key_elt in H1.
      destruct H1.
      apply Hp.
      apply H with p; auto;
        unfold pair_eq;
          split; unfold MapS.key in *; try rewrite H3; auto.
      (* p <> a /\ InA MapS.eq_key_elt p l *)
      apply Hne.
      apply ex_intro with p. auto.
    Qed.

  Definition exists_1 :
    forall (P : MapS.key * Data.t -> Prop)
      (Pdec : forall p, {P p} + {~ P p}) (m : M.t),
      {compat_P pair_eq P -> Exists_1 P m} +
      {compat_P pair_eq P -> ~ Exists_1 P m}.
    intros.
      unfold Exists_1.
      unfold compat_P in *.
      induction (MapS.elements m).
      (* base *)
      right.
      intro Heq.
      intro Hex.
      destruct Hex as [p Hex]; destruct Hex as [Hex Hex'].
      inversion Hex.
      (* induction *)
      destruct IHl as [He|Hne].
      (* exists *)
      left; intro Heq.
      generalize (He Heq). intros Hex.
      destruct Hex as [p Hex]; destruct Hex as [Hex Hex'].
      eapply ex_intro with p.
      split; auto.
      (* ~ exists *)
      (* either a is the pair we are looking for or not. *)
      case (Pdec a); intros Hp.
      (*  P a *)
      left.  intro Heq. apply ex_intro with a. split; unfold MapS.eq_key_elt; auto.
      (* ~ P a *)
      right. intro Heq. generalize (Hne Heq); intros Hne'.
      intro Hex.
      destruct Hex as [p Hex]. destruct Hex as [Hex Hex'].
      inversion Hex.
      (* p = a *)
      unfold MapS.eq_key_elt in H0.
      destruct H0.
      apply Hp.
      apply Heq with p; auto;
        unfold pair_eq;
          split; unfold MapS.key in *; try rewrite H2; auto.
      (* p <> a /\ InA MapS.eq_key_elt p l *)
      apply Hne'.
      apply ex_intro with p. auto.
    Qed.

    Definition exists_ :
      forall (P : MapS.key ->  Data.t -> Prop)
        (Pdec : forall k e, {P k e} + {~ P k e}) (m : M.t),
        {compat_P2 P -> Exists P m} +
        {compat_P2 P -> ~ Exists P m}.
    intros.
    generalize (exists_1 (pair_fn P) (pair_fn_dec Pdec) m); intros Hexists_1.
    (* destruct Hexists_1 and reduce *)
    destruct Hexists_1 as [Hexists_1|Hexists_1]; [left|right]; intro Hcompat;
      apply compat_P2_pair in Hcompat; apply Hexists_1 in Hcompat; clear Hexists_1;
        unfold Exists; unfold Exists_1 in Hcompat.
    (* exists *)
    destruct Hcompat as [p H]; destruct H as [H H'].
    destruct p as [k e]; apply ex_intro with k;
      apply ex_intro with e; split; try apply MapS.elements_2; auto.
    (* ~ exists *)
    intro Hexists; apply Hcompat; clear Hcompat.
    destruct Hexists as [k H]; destruct H as [e H]; destruct H as [H H'];
      apply ex_intro with (k,e); split; try apply MapS.elements_1; auto.
  Qed.

End MakeExists_fun.

Module MakeExists (M : Sord).

  Include MakeExists_fun M.MapS.E M.MapS M.Data M.

End MakeExists.


Set Implicit Arguments.

Require Import Arith_Max_extra.
Require Import LNameless_Meta.
Require Import LNameless_Meta_Env.
Require Import LNameless_Isomorphism.
Require Import LNameless_Fsub_Iso.
Require Import LN_Template_Two_Sort.

(* ************************************************************ *)
(** ** Fsub Part 1A and 2A *)

(** Reference: Chargueraud's POPL solution using Locally Nameless style
   and cofinite quantification *)

(****************************************************************************)
(****************************************************************************)
(** Here begins a concrete formalization of System Fsub for part 1A and 2A. *)
(****************************************************************************)
(****************************************************************************)

(** [typ] and [trm] are already defined in LNameless_Fsub_Iso.v
<<
Notation var := atom.

Inductive typ : Set :=
| typ_bvar  : nat -> typ
| typ_fvar  : var -> typ
| typ_top   : typ
| typ_arrow : typ -> typ -> typ
| typ_all   : typ -> typ -> typ.

Inductive trm : Set :=
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_app  : trm -> trm -> trm
| trm_abs  : typ -> trm -> trm
| trm_tapp : trm -> typ -> trm
| trm_tabs : typ -> trm -> trm.
>> *)

(** Many of the generic properties about substitution, environments are
   already proved in a generic
   *)

(** M_tt, M_yt, M_yy, and M_ty are already defined in LN_Template_Two_Sort.v *)

(** For cases where generic and non-generic concepts are mixed,
   it is sometimes better to work with original definitions.

   - Induction on well-formed terms is a typical case.
   - Although we have to give a double definition and
   prove its equivalence to the generic one,
   it still saves a lot about the generic properties.

   - It is still possible to work with the generic definitions only,
   but some proofs would demand size induction instead of structural inductions.
   *)

(** Original definition of well-formed types. *)

Inductive type : typ -> Prop :=
  | type_top : type typ_top
  | type_var : forall X, type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 -> type T2 -> type (typ_arrow T1 T2)
  | type_all : forall L T1 T2,
      type T1 -> (forall X, X `notin` L -> type (M_yy.M.Tbsubst T2 0 (typ_fvar X))) ->
      type (typ_all T1 T2).

Hint Constructors type.
Hint Resolve type_top type_var type_var type_all.

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      M_yy.M.TwfT V ->
      (forall x, x `notin` L -> term (M_tt.M.Tbsubst e1 0 (trm_fvar x))) ->
      term (trm_abs V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2)
  | term_tabs : forall L V e1,
      M_yy.M.TwfT V ->
      (forall X, X `notin` L -> term (M_yt.M.Tbsubst e1 0 (typ_fvar X))) ->
      term (trm_tabs V e1)
  | term_tapp : forall e1 V,
      term e1 ->
      M_yy.M.TwfT V ->
      term (trm_tapp e1 V).

Hint Constructors term.

Inductive wft : env typ -> env typ -> typ -> Prop :=
| wft_top : forall E F,
  wft E F typ_top
| wft_var : forall U E F X,
  binds X U E ->
  wft E F (typ_fvar X)
| wft_arrow : forall E F T1 T2,
  wft E F T1 ->
  wft E F T2 ->
  wft E F (typ_arrow T1 T2)
| wft_all : forall E F T1 T2 L V,
  wft E F T1 ->
  (forall X, X `notin` L -> wft (X ~ V ++ E) F (M_yy.M.Tbsubst T2 0 (typ_fvar X))) ->
  wft E F (typ_all T1 T2).

Hint Constructors wft.

(** The concept of "Binding" in Chargueraud's original code
   needs some adaptation

   - Instead of using mixed environments, we use two kinds of environments.
   - An environment is a pair of two disjoint environments.
   - One for subtyping variables
   - The other for term variables
   - We distinguish them by giving different names.

   - This is possible because there is no interaction between type variables
   and term variables.
   *)

(** Subtyping relation *)

Inductive sub : env typ -> env typ -> typ -> typ -> Prop :=
| sub_top : forall E F S,
  M_yy.Ywf_env E ->
  M_yy.YTenvT E F S ->
  sub E F S typ_top
| sub_refl_tvar : forall E F X,
  M_yy.Ywf_env E ->
  M_yy.YTenvT E F (typ_fvar X) ->
  sub E F (typ_fvar X) (typ_fvar X)
| sub_trans_tvar : forall U E F T X,
  binds X U E ->
  sub E F U T ->
  sub E F (typ_fvar X) T
| sub_arrow : forall E F S1 S2 T1 T2,
  sub E F T1 S1 ->
  sub E F S2 T2 ->
  sub E F (typ_arrow S1 S2) (typ_arrow T1 T2)
| sub_all : forall L E F S1 S2 T1 T2,
  sub E F T1 S1 ->
  (forall X, X `notin` L ->
    sub (X ~ T1 ++ E) F (M_yy.M.Tbsubst S2 0 (typ_fvar X)) (M_yy.M.Tbsubst T2 0 (typ_fvar X))) ->
  sub E F (typ_all S1 S2) (typ_all T1 T2).

(** Typing relation *)

Inductive typing : env typ -> env typ -> trm -> typ -> Prop :=
| typing_var : forall E F x T,
  YTwf_env E F ->
  binds x T F ->
  typing E F (trm_fvar x) T
| typing_abs : forall L E F V e1 T1,
  (forall x, x `notin` L ->
    typing E (x ~ V ++ F) (M_tt.M.Tbsubst e1 0 (trm_fvar x)) T1) ->
  typing E F (trm_abs V e1) (typ_arrow V T1)
| typing_app : forall T1 E F e1 e2 T2,
  typing E F e1 (typ_arrow T1 T2) ->
  typing E F e2 T1 ->
  typing E F (trm_app e1 e2) T2
| typing_tabs : forall L E F V e1 T1,
  (forall X, X `notin` L ->
    typing (X ~ V ++ E) F (M_yt.M.Tbsubst e1 0 (typ_fvar X)) (M_yy.M.Tbsubst T1 0 (typ_fvar X))) ->
  typing E F (trm_tabs V e1) (typ_all V T1)
| typing_tapp : forall T1 E F e1 T T2,
  typing E F e1 (typ_all T1 T2) ->
  sub E F T T1 ->
  typing E F (trm_tapp e1 T) (M_yy.M.Tbsubst T2 0 T)
| typing_sub : forall S E F e T,
  typing E F e S ->
  sub E F S T ->
  typing E F e T.

(** Values *)

Inductive value : trm -> Prop :=
| value_abs  : forall V e1, TTwfT (trm_abs V e1) ->
  value (trm_abs V e1)
| value_tabs : forall V e1, TTwfT (trm_tabs V e1) ->
  value (trm_tabs V e1).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
| red_app_1 : forall e1 e1' e2,
  TTwfT e2 ->
  red e1 e1' ->
    red (trm_app e1 e2) (trm_app e1' e2)
| red_app_2 : forall e1 e2 e2',
  value e1 ->
  red e2 e2' ->
    red (trm_app e1 e2) (trm_app e1 e2')
| red_tapp : forall e1 e1' V,
  M_yy.M.TwfT V ->
  red e1 e1' ->
    red (trm_tapp e1 V) (trm_tapp e1' V)
| red_abs : forall V e1 v2,
  TTwfT (trm_abs V e1) ->
  value v2 ->
  red (trm_app (trm_abs V e1) v2) (M_tt.M.Tbsubst e1 0 v2)
| red_tabs : forall V1 e1 V2,
  TTwfT (trm_tabs V1 e1) ->
  M_yy.M.TwfT V2 ->
  red (trm_tapp (trm_tabs V1 e1) V2) (M_yt.M.Tbsubst e1 0 V2).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E F e e' T,
  typing E F e T ->
  red e e' ->
    typing E F e' T.

Definition progress := forall e T,
  typing empty_env empty_env e T ->
  value e \/ exists e', red e e'.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 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.
*)

Require Import Way.Tactics.

Require Import Way.Preterm.

(* A binary relation over preterms. *)
Definition relation := preterm -> preterm -> Set.

Module Star.

(* The reflexive-transitive closure of a relation. *)
Inductive star (r : relation) : relation :=

(* Preterms relate to themselves. *)
| reflexivity : forall (t : preterm), star r t t

(* Preterms relate if related in the underlying relation *)
| include : forall (t u : preterm), r t u -> star r t u

(* Preterms relate if they relate to a third common preterm. *)
(* TODO(phs): Syntax-directed *)
| transitivity : forall (v t u : preterm), star r t v -> star r v u -> star r t u.

(* Don't need transitivity, which needs a parameter and so will never be inferred. *)
Hint Resolve reflexivity include : way.

End Star.

Export Star.

Module Equivalence.

(* The reflexive-symmetric-transitive closure of a relation. *)
Inductive equivalence (r : relation) : relation :=

(* Preterms relate to themselves. *)
| reflexivity : forall (t : preterm), equivalence r t t

(* Preterms relate if related in the underlying relation *)
| include : forall (t u : preterm), r t u -> equivalence r t u

(* Preterms relate if they relate to a third common preterm. *)
(* TODO(phs): Syntax-directed *)
| symmetry : forall (t u : preterm), equivalence r u t -> equivalence r t u

(* Preterms relate if they relate to a third common preterm. *)
(* TODO(phs): Syntax-directed *)
| transitivity :
  forall (v t u : preterm), equivalence r t v -> equivalence r v u -> equivalence r t u.

(* Don't add symmetry, search can spend its depth on useless pairs of applictions. *)
(* Don't need transitivity, which needs a parameter and so will never be inferred. *)
Hint Resolve reflexivity include : way.

End Equivalence.

Export Equivalence.

Module Examples.

Import Aliases.

Inductive example_relation : relation :=
| decrease : forall (n : nat), example_relation (type (S n)) (type n).

Example star_relations_are_reflexive : star example_relation (type 3) (type 3).
Proof.
  infer.
Defined.

Example star_relations_include_their_arguments : star example_relation (type 1) (type 0).
Proof.
  infer from decrease.
Defined.

Example star_relations_are_transitive : star example_relation (type 2) (type 0).
Proof.
  infer from (Star.transitivity example_relation (type 1)) decrease.
Defined.

Example equivalence_relations_are_reflexive :
  equivalence example_relation (type 2) (type 2).
Proof.
  infer.
Defined.

Example equivalence_relations_include_their_arguments :
  equivalence example_relation (type 1) (type 0).
Proof.
  infer from decrease.
Defined.

Example equivalence_relations_are_symmetric :
  equivalence example_relation (type 0) (type 1).
Proof.
  infer from Equivalence.symmetry decrease.
Defined.

Example equivalence_relations_are_transitive :
  equivalence example_relation (type 2) (type 0).
Proof.
  infer from
    (Equivalence.transitivity example_relation (type 1))
    decrease.
Defined.

End Examples.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e127m1_2limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.