(*Require Import QArith.
Require Import QArith.Qreals.*)
Require Import Reals.
Require Import Psatz.
Require Import QArith.Qminmax.
Require Lra.

Local Open Scope R_scope.

Axiom cheating : forall (A : Type), A.
Ltac cheat := apply cheating.

(* tactics for dealing with Rmin and Rmax *)
Ltac unfold_Rle_dec :=
  match goal with
  | |- context [Rle_dec ?a ?b] => destruct (Rle_dec a b) ; simpl ; unfold_Rle_dec
  | _ : context [Rle_dec ?a ?b] |- _ =>
    destruct (Rle_dec a b) ; simpl ; unfold_Rle_dec
  | _ => idtac
  end.

Ltac handle_Rminmax :=
  simpl ; unfold Rmin, Rmax in * ; unfold_Rle_dec.

(* Basic definitions. *)

Structure OpenInterval := {
  op_lower : R ;
  op_upper : R ;
  op_proper : op_lower < op_upper
}.

Structure ClosedInterval := {
  cl_lower : R ;
  cl_upper : R ;
  cl_proper : cl_lower <= cl_upper
}.

Structure PositiveInterval := {
  pos_interval :> OpenInterval ;
  pos_positive : op_lower pos_interval > 0
}.

Definition separated (a b : OpenInterval) :=
 op_upper a < op_lower b \/ op_upper b < op_lower a.

Definition overlap (a b : OpenInterval) :=
  (op_lower a < op_lower b /\ op_lower b < op_upper a) \/
  (op_lower b < op_lower a /\ op_lower a < op_upper b).

(* Note: this join only really works when applied to overlapping intervals. *)
Definition join (a b : OpenInterval) : OpenInterval.
Proof.
  refine {| op_lower := Rmin (op_lower a) (op_lower b) ;
            op_upper := Rmax (op_upper a) (op_upper b) |}.
  destruct a as [a1 a2 Pa].
  destruct b as [b1 b2 Pb].
  unfold Rmin, Rmax; simpl.
  handle_Rminmax ; lra.
Defined.

Definition closure : OpenInterval -> ClosedInterval.
Proof.
  intro a.
  refine {| cl_lower := op_lower a ; cl_upper := op_upper a |}.
  apply Rlt_le, op_proper.
Defined.

Definition opop_inside (a : OpenInterval) (b : OpenInterval) :=
  op_lower b <= op_lower a /\ op_upper a <= op_upper b.

Definition clop_inside (a : ClosedInterval) (b : OpenInterval) :=
  op_lower b < cl_lower a /\ cl_upper a < op_upper b.

Definition opcl_inside (a : OpenInterval) (b : ClosedInterval) :=
  cl_lower b <= op_lower a /\ op_upper a <= cl_upper b.

Definition clcl_inside a b :=
  cl_lower b <= cl_lower a /\ cl_upper a <= cl_upper b.

Definition well_inside (a b : OpenInterval) :=
  op_lower b < op_lower a /\ op_upper a < op_upper b.

Definition well_inside_tran a b c :
  well_inside a b -> well_inside b c -> well_inside a c.
Proof.
  destruct a, b, c.
  unfold well_inside.
  simpl.
  lra.
Qed.

(* Multiplication of a closed interval by a scalar. *)
Definition cl_scalar_mul (x : R) (a : ClosedInterval) : ClosedInterval.
Proof.
  refine {| cl_lower := Rmin (x * cl_lower a) (x * cl_upper a) ;
            cl_upper := Rmax (x * cl_lower a) (x * cl_upper a) |}.
  now apply Rminmax.
Defined.

(* Multiplication of an open interval by a non-zero scalar. *)
Definition op_scalar_mul (x : R) (H : x <> 0) (a : OpenInterval) :
  OpenInterval.
Proof.
  refine {| op_lower := Rmin (x * op_lower a) (x * op_upper a) ;
            op_upper := Rmax (x * op_lower a) (x * op_upper a) |}.
  destruct a.
  handle_Rminmax ; nra.
Defined.

Definition cl_in (x : R) (a : ClosedInterval) :=
  cl_lower a <= x /\ x <= cl_upper a.

Definition op_in (x : R) (a : OpenInterval) :=
  op_lower a < x /\ x < op_upper a.

(* If we make separated intervals smaller they are still separated. *)
Lemma separated_smaller a b a' b' :
   well_inside a' a -> well_inside b' b -> separated a b -> separated a' b'.
Proof.
  destruct a as [a1 a2 Pa].
  destruct b as [b1 b2 Pb].
  destruct a' as [a1' a2' Pa'].
  destruct b' as [b1' b2' Pb'].
  unfold well_inside, separated; simpl.
  lra.
Qed.

(* f is continuous on a closed interval a *)
Definition cl_continuous_on (f : R -> R) (a : ClosedInterval) :=
  forall x, cl_in x a -> continuity_pt f x.

Lemma cl_in_monotone x a b :
  cl_in x a -> clcl_inside a b -> cl_in x b.
Proof.
  destruct a, b.
  unfold cl_in, clcl_inside.
  simpl in *.
  lra.
Qed.

Lemma cl_continuous_restrict (f : R -> R) a b :
  cl_continuous_on f b -> clcl_inside a b -> cl_continuous_on f a.
Proof.
  intros H in_a_b x x_in_a.
  now apply H, (cl_in_monotone x a).
Qed.

Definition cl_lower_bound (f : R -> R) (a : ClosedInterval) (m : R) :=
  forall x, cl_in x a -> m <= f x.

Definition cl_upper_bound (f : R -> R) (a : ClosedInterval) (m : R) :=
  forall x, cl_in x a -> f x <= m.

(* the minimum of a continuous f on a closed interval a *)
Axiom cl_min :
  forall (f : R -> R) (a : ClosedInterval),
  cl_continuous_on f a ->
  { m : R | cl_lower_bound f a m /\
            (forall m', cl_lower_bound f a m' -> m' <= m) }.

Axiom cl_max :
  forall (f : R -> R) (a : ClosedInterval),
  cl_continuous_on f a ->
  { m : R | cl_upper_bound f a m /\
            (forall m', cl_upper_bound f a m' -> m <= m') }.

(* b is the image of a by f *)
Definition cl_is_image (f : R -> R) (a b : ClosedInterval) :=
  (forall x, cl_in x a -> cl_in (f x) b) /\
  (forall y, cl_in y b -> exists x, cl_in x a /\ f x = y).

(* The image of a closed interval by a contunuous function is a closed interval. *)
Definition cl_image (f : R -> R) (a : ClosedInterval) :
  cl_continuous_on f a ->
  { b : ClosedInterval | cl_is_image f a b }.
Proof.
  intro cont_f.
  destruct (cl_min f a cont_f) as [m m_is_glb].
  destruct (cl_max f a cont_f) as [M M_is_lub].
  assert (m_le_M : m <= M).
  { cheat. }
  exists {| cl_lower := m ; cl_upper := M ; cl_proper := m_le_M |}.
  split.
  - intros x x_in_a.
    split.
    + now apply m_is_glb.
    + now apply M_is_lub.
  - unfold cl_in; simpl.
    intros y [m_y y_M].
    cheat. (* intermediate value theorem *)
Defined.

(* Substraction of open intervals. *)
  Definition op_subtract (a b : OpenInterval) : OpenInterval.
Proof.
  refine {| op_lower := op_lower a - op_upper b ;
            op_upper := op_upper a - op_lower b |}.
  destruct a, b.
  simpl in *.
  lra.
Defined.

 Definition cl_subtract (a b : ClosedInterval) : ClosedInterval.
Proof.
  refine {| cl_lower := cl_lower a - cl_upper b ;
            cl_upper := cl_upper a - cl_lower b |}.
  destruct a, b.
  simpl in *.
  lra.
Defined.

Lemma minus_interval_image (f : R -> R)
      (a1 a2 : ClosedInterval)
      (c : OpenInterval) :
  forall (cont_f_a1 : cl_continuous_on f a1)
         (cont_f_a2 : cl_continuous_on f a2),
    (forall x y, cl_in x a1 ->
                 cl_in y a2 ->
                 op_in (f x - f y) c)
    ->
    clop_inside
      (cl_subtract
         (proj1_sig (cl_image f a1 cont_f_a1))
         (proj1_sig (cl_image f a2 cont_f_a2)))
      c.
Proof.
  intros cont_f_a1 cont_f_a2 H.
  destruct (cl_image f a1 cont_f_a1) as [fa1 [Ha1 Ga1]].
  destruct (cl_image f a2 cont_f_a2) as [fa2 [Ha2 Ga2]].
  simpl.
  unfold cl_is_image in *.
  destruct fa1 as [fa1_m fa1_M fa1_prop].
  destruct fa2 as [fa2_m fa2_M fa2_prop].
  destruct a1 as [a11 a12 a1_prop].
  destruct a2 as [a21 a22 a2_prop].
  unfold cl_in, cl_subtract, clop_inside in *.
  simpl in *.
  split.
  - destruct (Ga1 fa1_m) as [x_m [xm_in_a1 fxm_fa1m]].
    { lra. }
    destruct (Ga2 fa2_M) as [x_M [xM_in_a2 fxM_fa2M]].
    { lra. }
    rewrite <- fxm_fa1m.
    rewrite <- fxM_fa2M.
    now apply (H x_m x_M).
  - destruct (Ga1 fa1_M) as [y_M [yM_in_a1 fyM_fa1M]].
    { lra. }
    destruct (Ga2 fa2_m) as [y_m [ym_in_a2 fym_fa2m]].
    { lra. }
    rewrite <- fyM_fa1M.
    rewrite <- fym_fa2m.
    now apply (H y_M y_m).
Qed.

Definition op_multiply (a b : OpenInterval) : OpenInterval.
Proof.
  destruct a as [a1 a2 ?].
  destruct b as [b1 b2 ?].
  refine {| op_lower := Rmin (Rmin (a1 * b1) (a1 * b2)) (Rmin (a2 * b1) (a2 * b2)) ;
            op_upper := Rmax (Rmax (a1 * b1) (a1 * b2)) (Rmax (a2 * b1) (a2 * b2)) |}.
  handle_Rminmax ; nra.
Defined.

Definition Approx (f : R -> R) (a O : OpenInterval) :=
  forall x, cl_in x (closure a) -> op_in (f x) O.

Definition delta (a : OpenInterval) (b : ClosedInterval) (f : R -> R) :=
   forall x y : R, op_in x a -> op_in y a ->
                cl_in (f x - f y) (cl_scalar_mul (x - y) b).

Definition Delta (a O : OpenInterval) (A : OpenInterval -> OpenInterval -> Prop) :=
  forall a1 a2,
    well_inside a1 a ->
    well_inside a2 a ->
    separated a1 a2 ->
    exists a1' a2',
      A a1 a1' /\ A a2 a2' /\
      well_inside (op_subtract a1' a2') (op_multiply O (op_subtract a1 a2)).

Definition strong_delta (a : OpenInterval) (b : ClosedInterval) (f : R -> R) :=
   exists (a' b' : OpenInterval),
     well_inside a a' ->
     opcl_inside b' b ->
     forall x y : R, op_in x a' -> op_in y a' ->
                     cl_in (f x - f y) (cl_scalar_mul (x - y) (closure b')).

Definition StrongDelta (a O : OpenInterval) (A : OpenInterval -> OpenInterval -> Prop) :=
   exists a' O',
     well_inside a a' ->
     well_inside O' O ->
     forall a1 a2,
       well_inside a1 a' ->
       well_inside a2 a' ->
       separated a1 a2 ->
       exists a1' a2',
         A a1 a1' /\ A a2 a2' /\
         well_inside (op_subtract a1' a2') (op_multiply O' (op_subtract a1 a2)).

Structure bowtie (a : OpenInterval) (b : ClosedInterval) := {
  bow_map :> R -> R ;
  bow_lipschitz :
    forall x y : R, op_in x a -> op_in y a ->
                cl_in (bow_map x - bow_map y) (cl_scalar_mul (x - y) b)
}.

Structure ApproximableMap : Type := {
  app_map :> OpenInterval -> OpenInterval -> Prop ; (* this is our A *)
  app_monotone_r : forall a b c, app_map a b -> well_inside b c -> app_map a c ;
  app_monotone_l : forall a b c, app_map b c -> well_inside a b -> app_map a c ;
  app_total : forall a, exists b, app_map a b ; (* imagine: a A 1 *)
  app_disjoint : forall a b c, separated b c -> ~ (app_map a b /\ app_map a c) ; (* imagine: ~ (a A 0) *)
  app_directed : forall a b c, app_map a b -> app_map a c ->
                               exists d, well_inside d b /\ well_inside d c /\ app_map a d ;
  app_converge :
    forall a b c, overlap b c ->
    app_map a (join b c) ->
    exists a1 a2, overlap a1 a2 /\ well_inside a (join a1 a2) /\
                  app_map a1 b /\ app_map a2 c
  (* exercise: define this so that you can prove approximable_filter_maps below. *)
}.

Structure Bowtie (a O : OpenInterval)  := {
  Bow_map :> ApproximableMap ;
  Bow_lipschitz : Delta a O Bow_map
}.

(* A completely prime filter w.r.t. to the well-inside order. *)
Structure CompleteFilter : Type := {
  cf_filter :> OpenInterval -> Prop ;
  cf_monotone : forall a b, well_inside a b -> cf_filter a -> cf_filter b ;
  cf_inhabited : exists a, cf_filter a ; (* imagine: (-inf, inf) is in cf_filter *)
  cf_disjoint : forall a b, separated a b -> ~ (cf_filter a /\ cf_filter b) ; (* imagine: empty set is not in cf_filter *)
  cf_directed : forall a b, cf_filter a -> cf_filter b -> exists c,
                                well_inside c a /\ well_inside c b /\ cf_filter c ;
  cf_converge: forall a b, overlap a b -> cf_filter (join a b) -> cf_filter a \/ cf_filter b (* the filter is prime *)
}.

Definition frame_map
           (A : OpenInterval -> OpenInterval -> Prop)
           (F : OpenInterval -> Prop) : OpenInterval -> Prop :=
  fun b => exists a, A a b /\ F a.

Definition filter_map (A : ApproximableMap) : CompleteFilter -> CompleteFilter.
Proof.
  intro F.
  refine {| cf_filter := frame_map A F |}.
  - intros a b Wab [c [Aca Fc]].
    exists c.
    split.
    + now apply (app_monotone_r _ c a b).
    + assumption.
  - unfold  frame_map.
    destruct (cf_inhabited F) as [a' Fa'].
    destruct (app_total A a') as [a'' Aa'a''].
    now exists a'', a'.
  - intros a b sep_ab.
    intros [[c [Aca Fc]] [d [Adb Fd]]].
    destruct (cf_directed F c d Fc Fd) as [e [Wea [Wed Fe]]].
    assert (Aea : A e a).
    { eapply app_monotone_l.
      - exact Aca.
      - assumption. }
    assert (Aeb : A e b).
    { eapply app_monotone_l.
      - exact Adb.
      - assumption. }
    pose (G := app_disjoint A e a b sep_ab).
    now absurd (A e a /\ A e b).
   - intros a b [c [Aca Fc]] [d [Adb Fd]].
    destruct (cf_directed F c d Fc Fd) as [e [Wec [Wed Fe]]].
    assert (Aea : A e a).
    { eapply app_monotone_l.
      - exact Aca.
      - assumption. }
    assert (Aeb : A e b).
    { eapply app_monotone_l.
      - exact Adb.
      - assumption. }
    destruct (app_directed A e a b Aea Aeb) as [c' [Wc'a [Wc'b Aec']]].
    exists c'.
    split ; [ assumption  | split ; [ assumption | unfold frame_map] ].
    now exists e.
  - intros a b ovl_ab [c [Acjab Fc]].
    unfold frame_map.
    destruct (app_converge A c a b ovl_ab Acjab) as [a' [b' [ovl_a'b' [Wcja'b' [Aa'a Ab'b]]]]].
    assert (Fja'b' : F (join a' b')).
    { eapply cf_monotone. exact Wcja'b'. assumption. }
    destruct (cf_converge F a' b' ovl_a'b' Fja'b') as [Fa' | Fb'].
    + left. now exists a'.
    + right. now exists b'.
Defined.

Definition point2filter (x : R) : CompleteFilter.
Proof.
  intros.
  refine {| cf_filter := fun a => op_in x a |}.
  - intros a b Wab x_in_a.
    unfold op_in in *.
    destruct Wab.
    destruct x_in_a.
    split.
     + lra.
     + lra.
   - assert (C : x-1 < x+1) by lra.
     exists {| op_lower := x-1; op_upper := x+1; op_proper := C |}.
     unfold op_in in *.
     simpl in *.
     lra.
   - intros.
     unfold not.
     intros.
     destruct H.
     unfold op_in in *.
     destruct H0, H1.
     + destruct H0.
       lra.
     + destruct H0.
       unfold op_in in *.
       lra.
   - intros.
     destruct a as [a1 a2 a_prop].
     destruct b as [b1 b2 b_prop].
     destruct H. simpl in *.
     destruct H0. simpl in *.
     unfold well_inside in *. simpl in *.
     assert (G: (Rmax a1 b1 +x)/2 < (Rmin a2 b2 +x)/2).
     { handle_Rminmax ; lra. }
     exists {| op_lower := (Rmax a1 b1 + x) / 2;
               op_upper := (Rmin a2 b2 + x) / 2;
               op_proper := G |}.
     simpl in *.
     repeat split ; handle_Rminmax ; lra.
   - intros a b H [G1 G2].
     destruct a, b.
     unfold overlap, join, op_in in * ; simpl in *.
     handle_Rminmax ; lra.
Defined.

Lemma lower_below_upper (F : CompleteFilter) a b :
  F a -> F b -> op_lower a < op_upper b.
Proof.
   intros Fa Fb.
   destruct (cf_directed F a b Fa Fb) as [c[Wca [Wcb Fc]]].
   destruct Wca, Wcb.
   eapply Rlt_trans.
   + apply H.
   + apply (Rlt_trans (op_lower c) (op_upper c) (op_upper b)).
     - apply (op_proper c).
     - assumption.
Defined.

Lemma filter2point (F : CompleteFilter) : R.
Proof.
  (* The set of lower bounds of the number we are constructing. *)
  pose (E := fun y => exists a, F a /\ y < op_lower a ).
  assert (bE : bound E).
  { destruct (cf_inhabited F) as [a Fa].
    exists (op_upper a).
    intros y [b [Fb x_leq_b]].
    apply Rlt_le.
    apply (Rle_lt_trans y (op_lower b) (op_upper a)).
    + now apply Rlt_le.
    + now apply (lower_below_upper F).
  }
  assert (inhE : exists y : R, E y).
  { destruct (cf_inhabited F) as [a Fa].
    exists (op_lower a - 1).
    unfold E.
    exists a.
    split.
    - assumption.
    - lra.
  }
  destruct (completeness E bE inhE) as [x lub_x].
  exact x.
Defined.

Lemma filter_point_inverse (x : R) :
  x = filter2point (point2filter x ).
Proof.
 pose (E := fun y => exists a, (point2filter x) a /\ y < op_lower a ).
   assert (bE : bound E).
  { destruct (cf_inhabited (point2filter x)) as [a Fa].
    exists (op_upper a).
    intros y [b [Fb x_leq_b]].
    apply Rlt_le.
    apply (Rle_lt_trans y (op_lower b) (op_upper a)).
    + now apply Rlt_le.
    + now apply (lower_below_upper (point2filter x)).
  }
 assert (inhE : exists y : R, E y).
  { destruct (cf_inhabited (point2filter x)) as [a Fa].
    exists (op_lower a - 1).
    unfold E.
    exists a.
    split.
    - assumption.
    - lra.
  }
  destruct (completeness E bE inhE) as [z lub_z].
  assert (Eq: z = filter2point (point2filter x)).
  admit.
Admitted.

Lemma point_filter_inverse (F : CompleteFilter) :
  forall a, F a <-> (point2filter (filter2point F)) a.
Admitted. (* exercise *)

Definition dual_fun (A : ApproximableMap) (x : R) :=
  filter2point (filter_map A (point2filter x)).

Definition interpol (a : ClosedInterval) (b : OpenInterval) :
  clop_inside a b -> exists b' : OpenInterval, clop_inside a b' /\ well_inside b' b.
Proof.
   intros.
   destruct a, b.
   rename
      cl_lower0 into a1,
      cl_upper0 into a2,
      cl_proper0 into a_prop,
      op_lower0 into b1,
      op_upper0 into b2,
      op_proper0 into b_prop.
    pose (c1 := (a1+b1)*(1/2)).
    pose (c2 := (a2+b2)*(1/2)).
    assert (C : c1 < c2).
    { unfold c1, c2. lra . }
    exists {| op_lower := c1; op_upper := c2; op_proper := C |}.
    unfold clop_inside in *.
    unfold op_lower in *.
    unfold cl_lower in *.
    unfold cl_upper in *.
    unfold op_upper in *.
    unfold well_inside in *.
    unfold c1, c2 in *.
    simpl.
    nra.
Defined.

Lemma R_Hausdorff (x y : R) :
  x <> y ->
  exists a b : OpenInterval, op_in x a /\ op_in y b /\ (separated a b).
Proof.
  intro Nxy.
  destruct (Rdichotomy x y Nxy).
  - pose (a1 := x - 1).
    pose (a2 := (2 * x + y) / 3).
    assert (a_prop : a1 < a2).
    { unfold a1, a2. lra. }
    pose (b1 := (x + 2 * y) / 3).
    pose (b2 := y + 1).
    assert (b_prop : b1 < b2).
    { unfold b1, b2. lra. }
    exists {| op_lower := a1; op_upper := a2; op_proper := a_prop |}.
    exists {| op_lower := b1; op_upper := b2; op_proper := b_prop |}.
    unfold op_in, separated; simpl.
    unfold a1, a2, b1, b2.
    lra.
  - pose (a2 := x + 1).
    pose (a1 := (2 * x + y) / 3).
    assert (a_prop : a1 < a2).
    { unfold a1, a2. lra. }
    pose (b2 := (x + 2 * y) / 3).
    pose (b1 := y - 1).
    assert (b_prop : b1 < b2).
    { unfold b1, b2. lra. }
    exists {| op_lower := a1; op_upper := a2; op_proper := a_prop |}.
    exists {| op_lower := b1; op_upper := b2; op_proper := b_prop |}.
    unfold op_in, separated; simpl.
    unfold a1, a2, b1, b2.
    lra.
Qed.

Lemma point_directedness (x : R) (a b : OpenInterval) :
  op_in x a -> op_in x b ->
  exists c, op_in x c /\ well_inside c a /\ well_inside c b.
Proof.
   intros x_in_a x_in_b.
   destruct x_in_a, x_in_b.
   pose (z1 := Rmax (op_lower a) (op_lower b)).
   pose (z2 := Rmin (op_upper a) (op_upper b)).
   unfold Rmax in *.
   destruct (Rle_dec (op_lower a) (op_lower b)).
   unfold Rmin in *.
   destruct (Rle_dec (op_upper a) (op_upper b)).
   assert (G: (z1+x)/2 < (z2+x)/2).
      {unfold z1, z2. lra. }
   exists {|op_lower := (z1+x)/2;
               op_upper := (z2+x)/2;
               op_proper := G |}.
    - unfold op_in in *. simpl in *.
      split.
      + split.
        ** unfold z1. lra.
        **  unfold z2. lra.
      + split.
        ** unfold well_inside in *. simpl in *. split.
           -- unfold z1. lra.
           -- unfold z2. lra.
        ** unfold well_inside in *. simpl in *. split.
           -- unfold z1. lra.
           -- unfold z2. lra.
   - assert (G: (z1+x)/2 < (z2+x)/2).
      {unfold z1, z2. lra. }
      exists {|op_lower := (z1+x)/2;
               op_upper := (z2+x)/2;
               op_proper := G |}.
      unfold op_in in *. simpl in *.
      split.
      + split.
        ** unfold z1. lra.
        **  unfold z2. lra.
      + split.
        ** unfold well_inside in *. simpl in *. split.
           -- unfold z1. lra.
           -- unfold z2. lra.
        ** unfold well_inside in *. simpl in *. split.
           -- unfold z1. lra.
           -- unfold z2. lra.
    - unfold Rmin in *.
      destruct (Rle_dec (op_upper a) (op_upper b)).
      assert (G: (z1+x)/2 < (z2+x)/2).
      {unfold z1, z2. lra. }
      exists {|op_lower := (z1+x)/2;
               op_upper := (z2+x)/2;
               op_proper := G |}.
      unfold op_in in *. simpl in *.
      split.
      + split.
        ** unfold z1. lra.
        **  unfold z2. lra.
      + split.
        ** unfold well_inside in *. simpl in *. split.
           -- unfold z1. lra.
           -- unfold z2. lra.
        ** unfold well_inside in *. simpl in *. split.
           -- unfold z1. lra.
           -- unfold z2. lra.
      +  assert (G: (z1+x)/2 < (z2+x)/2).
      {unfold z1, z2. lra. }
      exists {|op_lower := (z1+x)/2;
               op_upper := (z2+x)/2;
               op_proper := G |}.
      unfold op_in in *. simpl in *.
      unfold well_inside in *. simpl in *.
      split.
         ***  unfold z1, z2.
              lra.
         *** unfold z1, z2. lra.
Defined.

Lemma closed_in_from_open_in (x : R) (a : ClosedInterval) :
  ((forall c, clop_inside a c -> op_in x c) <-> cl_in x a).
Proof.
  split.
  - intro H.
    unfold cl_in.
    split.
    + destruct a as [a1 a2 prop_a].
      unfold clop_inside in *.
      simpl in *.
      admit.
    + admit.
  - intros x_in_a c ins_ac.
    unfold well_inside, op_in, clop_inside, cl_in in *.
    destruct a, c.
    simpl in *.
    lra.
Admitted.
Print clop_inside.
Check op_subtract.

Lemma scott_continuity (b1 b2 : ClosedInterval) (O: OpenInterval):
  clop_inside (cl_subtract b1 b2) O ->
  exists c1 c2 : OpenInterval,
    clop_inside b1 c1 /\ clop_inside b2 c2 /\ well_inside (op_subtract c1 c2) O.
Proof.
   intros.
   destruct b1 as [x1 y1 b1_prop].
   destruct b2 as [x2 y2 b2_prop].
   destruct O as [O1 O2 O_prop].
   destruct H as [H1 H2].
   unfold clop_inside, well_inside in *.
   simpl in *.
   pose (d1 := (O2 - y1 + x2)/4).
   pose (d2 := (x1 - y2 - O1)/4).
   pose (d := Rmin d1 d2).
   unfold Rmin in *.
   destruct (Rle_dec d1 d2).
   - assert (G1 : x1 - d < y1 +d).
     {unfold d. unfold d1. lra. }
     assert (G2 : x2 - d < y2 +d).
     {unfold d. unfold d1. lra. }
     exists {| op_lower := x1 - d ;
               op_upper := y1 + d ;
               op_proper := G1|}.
     exists {| op_lower := x2 - d ;
               op_upper := y2 + d ;
               op_proper := G2|}.
     unfold d, d1, d2 in *; simpl.
     nra.
   - assert (G1 : x1 - d < y1 +d).
     {unfold d. unfold d2. lra. }
     assert (G2 : x2 - d < y2 +d).
     {unfold d. unfold d2. lra. }
     exists {| op_lower := x1 - d ;
               op_upper := y1 + d ;
               op_proper := G1|}.
     exists {| op_lower := x2 - d ;
               op_upper := y2 + d ;
               op_proper := G2|}.
     unfold d, d1, d2 in *; simpl.
     nra.
Defined.

Lemma lipschitz_is_continuous a b (f : bowtie a b) c :
  clop_inside c a -> cl_continuous_on f c.
Proof.
  cheat.
Qed.

Lemma cl_op_trans a b c :
  clop_inside a b -> opop_inside b c -> clop_inside a c.
Proof.
  cheat.
Qed.

Lemma inside_mul x y a1 a2 b O:
  cl_in x (closure a1) ->
  cl_in y (closure a2) ->
  separated a1 a2 ->
  clop_inside b O ->
  clop_inside (cl_scalar_mul (x - y) b) (op_multiply O (op_subtract a1 a2)).
Proof.
  intros x_in_a1 y_in_a2 sep_a1a2 [b_in_O1 b_in_O2].
  assert (xy_not_zero : x - y <> 0).
  { destruct a1, a2.
    unfold cl_in, closure, separated in * ; simpl in *.
    lra.
  }
  apply (cl_op_trans _ (op_scalar_mul (x - y) xy_not_zero O)).
  - destruct a1, a2, b, O.
    unfold clop_inside, cl_scalar_mul, op_scalar_mul, cl_in, separated in * ;
    simpl in *.
    handle_Rminmax ; nra.
  - destruct a1, a2, b, O.
    unfold opop_inside, cl_scalar_mul, op_scalar_mul, cl_in, separated in * ;
    simpl in *.
    admit. (* difficult? *)
Admitted.

(* Main theorems *)

Theorem main_theorem1 (a O : OpenInterval) (A : Bowtie a O):
  delta a (closure O) (dual_fun A).
Proof.
  destruct A as [A DA].
  unfold delta in *. simpl in *.
  intros x y x_in_a y_in_a.
  destruct (Req_dec x y).
   - destruct H.
     admit.
   - destruct (R_Hausdorff x y H) as [a' [b' [x_in_a' [y_in_b' sep_a'b']]]].
     destruct (point_directedness x a' a x_in_a' x_in_a) as [a'' [x_in_a'' [W_a''a' W_a''a]]].
     destruct (point_directedness y b' a y_in_b' y_in_a) as [b'' [y_in_b'' [W_b''b' W_b''a]]].
     unfold Delta in DA.
     destruct (DA a'' b'') as [d [e [Aa''d [Aa''e WI]]]]; try assumption.
     { now apply (separated_smaller a' b'). }
     assert (df_Ax_in_d : op_in (dual_fun A x) d).
     { admit.
     }
     assert (df_Ay_in_e : op_in (dual_fun A y) e).
     { admit. }
     assert (dfxy_in_de : op_in (dual_fun A x - dual_fun A y) (op_subtract d e)).
     { admit. }
     admit.
Admitted.

Lemma clop_in_trans x a b :
  cl_in x a -> clop_inside a b -> op_in x b.
Proof.
  admit.
Admitted.

Theorem main_theorem2 (a : OpenInterval) (b : ClosedInterval) (f : bowtie a b) :
  forall O : OpenInterval, clop_inside b O ->
  forall a0 : OpenInterval, clop_inside (closure a0) a -> Delta a0 O (Approx f).
Proof.
  intros O ins_bO c ins_c_a.
  intros a1 a2 wi_a1c wi_a2c sep_a1a2.
  assert (cont_f_a1 : cl_continuous_on f (closure a1)).
  { apply lipschitz_is_continuous.
    destruct a1, a, c; unfold clop_inside, well_inside in *.
    simpl in *.
    lra.
  }
  assert (cont_f_a2 : cl_continuous_on f (closure a2)).
  { apply lipschitz_is_continuous.
    destruct a2, a, c; unfold clop_inside, well_inside in *.
    simpl in *.
    lra.
  }
  destruct (cl_image f (closure a1) (cont_f_a1)) as [b1 imag_b1].
  destruct (cl_image f (closure a2) (cont_f_a2)) as [b2 imag_b2].
  destruct (scott_continuity b1 b2 (op_multiply O (op_subtract a1 a2)))
    as [c1 [c2 [b1_in_c1 [b2_in_c2 H]]]].
  { destruct imag_b1 as [H1 H2].
    destruct imag_b2 as [G1 G2].
    destruct b1 as [b1_m b1_M b1_prop].
    destruct b2 as [b2_m b2_M b2_prop].
    unfold cl_subtract, clop_inside, cl_in  in *; simpl in *.
    destruct (H2 b1_m) as [xm [xm_in_a1 Exm]]. { lra. }
    destruct (H2 b1_M) as [xM [xM_in_a1 ExM]]. { lra. }
    destruct (G2 b2_m) as [ym [ym_in_a2 Eym]]. { lra. }
    destruct (G2 b2_M) as [yM [yM_in_a2 EyM]]. { lra. }
    rewrite <- Exm.
    rewrite <- ExM.
    rewrite <- Eym.
    rewrite <- EyM.
    split.
    - assert (K : op_in (f xm - f yM) (op_multiply O (op_subtract a1 a2))).
      { apply (clop_in_trans _ (cl_scalar_mul (xm - yM) b)).
        - admit. (* apply f, then it's easy *)
        - now apply inside_mul.
      }
      apply K.
    - admit. (* symmetric to the above. *)
  }
  exists c1, c2.
  repeat split.
  - apply (Rlt_le_trans _ (cl_lower b1)).
    + apply b1_in_c1.
    + now apply imag_b1.
  - apply (Rle_lt_trans _ (cl_upper b1)).
    + now apply imag_b1.
    + apply b1_in_c1.
  - apply (Rlt_le_trans _ (cl_lower b2)).
    + apply b2_in_c2.
    + now apply imag_b2.
  - apply (Rle_lt_trans _ (cl_upper b2)).
    + now apply imag_b2.
    + apply b2_in_c2.
  - apply H.
  - apply H.
Admitted.

 (*
  intros [O1 O2 Proper_O] [Inside_bO] [a01 a02 Proper_a0] [Inside_a0a_1 Inside_a0a_2]
         [c1 c2 Proper_c] [d1 d2 Proper_d] [WI_ca1 WI_ca2] [WI_da1 WI_da2] Separated_cd.
  destruct a as [a1 a2 Proper_a].
  destruct b as [b1 b2 Proper_b].
  destruct f as [f Lipschitz_f].
  unfold op_in, cl_in in Lipschitz_f.
  unfold Delta, Approx.
  unfold separated, well_inside, inside in *.
  unfold cl_in, op_in.
  simpl in *. *)
  intros.
  admit.
Admitted.

Theorem strong_main_theorem1 (a O : OpenInterval) (A : Bowtie a O):
  exists b,clop_inside b O /\ strong_delta a b (dual_fun A).
Admitted.

Theorem strong_main_theorem2 (a : OpenInterval) (b : ClosedInterval) (f : bowtie a b) :
  forall O : OpenInterval,
   clop_inside b O ->
    StrongDelta a O (Approx f).
Proof.
Admitted.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * kat_untyping: untyping theorem for KAT *)

(** We prove a strong untyping theorem for KAT:
   - types can be erased (as in the untyping theorem in [untyping])
   - predicate variables of distinct types can be merged

   The proofs are quite simple since we can perform them at the level
   of guarded string languages: unlike for KA, we proved typed
   completeness of KAT w.r.t. these models. *)

Require Import kat gregex ugregex ordinal positives glang.
Set Implicit Arguments.

Section s.
Variable Pred: nat.
Notation Atom := (ord (pow2 Pred)).
Notation Sigma := positive.
Variables src tgt: Sigma -> positive.
Notation pred := (ord Pred).
Notation gregex := (gregex_kat_ops Pred src tgt).
Notation ugregex := (ugregex_monoid_ops Pred ugregex_tt ugregex_tt).
Notation glang := (@gregex.lang Pred src tgt).
Notation uglang := (@ugregex.lang Pred).
Notation typed := (@typed' Atom src tgt).

(** type-erasing function on extended regular expressions *)

Fixpoint gerase n m (e: gregex n m): ugregex :=
  match e with
    | g_zer _ _ _ => 0
    | g_prd _ _ p => u_prd p
    | g_pls e f => gerase e + gerase f
    | g_dot e f => gerase e * gerase f
    | g_itr e => gerase e ^+
    | g_var i => u_var _ i
  end.

(** charaterisation of the guarded string language of erased epressions *)

Lemma uglang_gerase n m (e: gregex n m):
  uglang (gerase e) == eval (fun _ => traces_tt) (fun _ => @lsyntax.e_var _) tsingle e.
Proof.
  induction e; simpl gerase.
   apply lang_0.
   simpl. rewrite lsyntax.eval_var. reflexivity.
   reflexivity.
   now apply cup_weq.
   now apply dot_weq.
   now apply itr_weq.
Qed.

Corollary gerase_weq n m: Proper (weq ==> weq) (@gerase n m).
Proof. intros ? ? H. simpl. unfold u_weq. rewrite 2uglang_gerase. apply (H _ _ _). Qed.

(** the a priori untyped guarded string language of a typed gregex is necessarily typed *)

Lemma typed_uglang_gerase n m (e: gregex n m): typed n m (uglang (gerase e)).
Proof.
  induction e.
   intros [|] H. discriminate. destruct H.
   apply typed'_inj.
   apply typed'_single.
   revert IHe1 IHe2. apply typed'_cup.
   revert IHe1 IHe2. apply typed'_dot.
   revert IHe. apply typed'_itr.
Qed.

(** we can thus recover the typed language out of the untyped one *)

Notation restrict := (restrict src tgt).

Theorem untype_glang n m (e: gregex n m): glang e == restrict n m (uglang (gerase e)).
Proof.
  symmetry. induction e.
   setoid_rewrite lang_0. apply restrict_0.
   setoid_rewrite restrict_inj. simpl. unfold ttraces_weq. simpl. now rewrite lsyntax.eval_var.
   apply restrict_single.
   etransitivity. 2: apply cup_weq; eassumption. apply restrict_pls.
   etransitivity. 2: apply dot_weq; eassumption. apply restrict_dot; apply typed_uglang_gerase.
   etransitivity. 2: apply itr_weq; eassumption. apply restrict_itr; apply typed_uglang_gerase.
Qed.

End s.


(*Authors: Syed Mohammed Arshad Zaidi, Anuj Sharma*)

Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.

Notation "( x , y )" := (pair x y).
Notation "[ ]" := nil.

(* This is representation of single node of a graph *)
Inductive node :=
 Node : nat -> node.

(* Raw function to check equality of nodes. *)
Definition nodes_equal (x y:node): bool:=
    match x with |Node a => (match y with |Node b => beq_nat a b end) end.

 (* Raw function to search a given node in a given graph. *)
 Definition search_node (ps : list (node * (list node)) ) (x:node): option (list node) :=
 match find (fun p => nodes_equal x (fst p)) ps with
 | Some p => Some (snd p)
 | None => Some []
 end.

 (* Wrapper function on search_node for searching node in a given graph. *)
 Definition is_node_present (ps:list(node* (list node))) (default:list node) (x:node) : list node :=
 match search_node ps x with
 | None => default
 | Some y => y
 end.

 (** Since pairs are used quite a bit, it is nice to be able to
 write them with the standard mathematical notation [(x,y)] instead
 of [pair x y].  We can tell Coq to allow this with a [Notation]
 declaration. *)

 (** As with pairs, it is more convenient to write lists in
 familiar programming notation.  The following declarations
 allow us to use [::] as an infix [cons] operator and square
 brackets as an "outfix" notation for constructing lists. *)

 Notation "x :: l" := (cons x l)
 (at level 60, right associativity).
 Notation "[ ]" := nil.
 Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

 Definition customNode := Node 1.
 Definition noCustomNode := Node 404.
 Definition customGraph := [(Node 1, [Node 2; Node 3]);(Node 2, [Node 4;Node 5]); (Node 3, [Node 6; Node 7]);(Node 4, [Node 8; Node 9])].

 Check customGraph.

 Compute (search_node customGraph (Node 2)).

 Compute (is_node_present customGraph [] (Node 2)).

 Compute (nodes_equal (Node 2) (Node 4)).

 Compute (is_node_present customGraph [] customNode).

 (* This function will remove node from graph which is passed. *)
 Fixpoint remove_node (g: list(node*(list node))) (r: node) : list(node*(list node)) :=
   match g with
   | [] => []
   | h::t => match h with
             | (x,y) => match nodes_equal x r with
                        | true => t
                        | false => h::(remove_node t r)
                        end
             end
   end.

 Fixpoint remove_node_list (l: list node) (n: node) : list node :=
   match l with
   | [] => []
   | h::t => match nodes_equal n h with
             | true => remove_node_list t n
             | false => h::(remove_node_list t n)
             end
   end.

 Inductive id : Type :=
 | Id : nat -> id.

 Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

 Definition total_map (A:Type) := id -> A.

 Definition t_empty {A:Type} (v : A) : total_map A :=
   (fun _ => v).

 Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp                (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

(* Function for bfs traversal of custom graph. *)
 (* Fixpoint bfs (g:list(node*(list node))) (s:list node) : list node :=
   match s with
   | [] => []
   | h::t => h::(bfs g (t ++ (is_node_present g [] h)))
   end.
  *)

Definition state := total_map nat.

Definition empty_state : state :=
  t_empty 0.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x                                (* <----- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult :  forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where "e '\\' n" := (aevalR e n) : type_scope.

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st \\ (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
    END.

Definition fact_in_coq' : com :=
  Y ::= ANum 1;;
  Z ::= ANum 3;;

  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
    END.

Compute t_update (t_update (t_update empty_state X 2) Z 0) Y 2.
Compute t_update empty_state X 2.

Example test_fact: fact_in_coq'
   / empty_state
   \\ (t_update(t_update(t_update(t_update(t_update(t_update(t_update(t_update empty_state Y 1) Z 3) Y 3) Z 2) Y 6) Z 1) Y 6) Z 0).
Proof.
  unfold fact_in_coq'.
  apply E_Seq with (t_update empty_state Y 1).
  - apply E_Ass. reflexivity.
  - apply E_Seq with (t_update (t_update empty_state Y 1) Z 3).
    + apply E_Ass. reflexivity.
    + apply E_WhileLoop with (t_update(t_update(t_update(t_update empty_state Y 1) Z 3) Y 3) Z 2).
      * reflexivity.
      * apply E_Seq with (t_update(t_update (t_update empty_state Y 1) Z 3) Y 3).
        { apply E_Ass. reflexivity. }
        { apply E_Ass. reflexivity. }
      * apply E_WhileLoop with (t_update(t_update(t_update(t_update(t_update(t_update empty_state Y 1) Z 3) Y 3) Z 2) Y 6) Z 1).
        { reflexivity. }
        { apply E_Seq with (t_update(t_update(t_update(t_update(t_update empty_state Y 1) Z 3) Y 3) Z 2) Y 6).
          { apply E_Ass. reflexivity. }
          { apply E_Ass. reflexivity. }
        }
        { apply E_WhileLoop with (t_update(t_update(t_update(t_update(t_update(t_update(t_update(t_update empty_state Y 1) Z 3) Y 3) Z 2) Y 6) Z 1) Y 6) Z 0).
          { reflexivity. }
          { apply E_Seq with (t_update(t_update(t_update(t_update(t_update(t_update(t_update empty_state Y 1) Z 3) Y 3) Z 2) Y 6) Z 1) Y 6).
            { apply E_Ass. reflexivity. }
            { apply E_Ass. reflexivity. } }
          { apply E_WhileEnd. simpl. reflexivity. } }
Qed.

 Fixpoint node_in_list (l: list node) (n: node) : bool :=
   match l with
   | [] => false
   | h::t => match nodes_equal h n with
             | true => true
             | false => node_in_list t n
             end
   end.

 Fixpoint unique_list (r: list node) (l: list node) : list node :=
   match l with
   | [] => r
   | h::t => match node_in_list r h with
             | false => unique_list (r ++ [h]) t
             | true => unique_list r t
             end
   end.

 (*
Inductive bfs_ind : graph -> list node -> Prop :=
| bfs_empty : bfs_ind [] []
| bfs_single : forall n, bfs_ind [(n,[])] [n]
| bfs_list_s: forall g n l l' n', bfs_ind [(n,l');g] l -> bfs_ind [(n',[n]);(n,l');g] (n':: l).

  *)

Definition inputGraph := [(Node 1, [Node 2; Node 3]);(Node 2, [Node 3;Node 4]); (Node 3, [Node 4; Node 5]);(Node 4, [Node 5; Node 6]);(Node 5, [Node 6;Node 7]); (Node 6, [Node 7; Node 8]); (Node 7,[Node 8; Node 9]); (Node 8,[Node 9;Node 10]); (Node 9,[]); (Node 10,[])].

Definition totalNodes := (ANum 4).

Fixpoint get_next_node_num_iter (n: nat) (l : list node): option (nat) :=
  match n with
   | O => match l with
            | [] => None
            | h::t => match h with | (Node x) => Some x end
          end
   | S m => match l with
            | [] => None
            | h::t => get_next_node_num_iter m t
            end
  end.

Definition get (l:list node): option node :=
  match l with
  |[] => None
  |x::xs => Some x
  end.

Definition pop (l:list node): option (list node) :=
  match l with
  |[] => None
  |x::xs => Some xs
  end.

Definition bfs_iteration  (graph : list (node * list node)) (current_stack : list node) : option (list node):=
  match get current_stack with
 | None => None
 | Some n => match search_node graph n with
               |None => None
               |Some l => Some (unique_list [] ([n]++(tl current_stack) ++ l))
             end
 end.

Fixpoint bfs_aux (graph : list (node * (list node))) (current_stack:list node):
  option (list node) :=
   match graph with
   | [] => Some []
   | [x] => Some [fst x]
   | x::xs  => match (bfs_iteration xs (current_stack ++ (snd x))) with
               |None => None
               |Some z =>
                match (pop z) with
                |None => None
                |Some p => match (bfs_aux xs p) with
                           |None => None
                           |Some r  =>  match get z with
                                        |None => None
                                        |Some w => Some ([w] ++ r)
                                                        end
                           end
                end
               end
   end.

Definition bfs (graph : list (node * (list node))) : option (list node) :=
  match graph with
   | [] => None
   | x::xs =>  match (bfs_aux xs (snd x)) with
               |None => None
               |Some r => Some ((fst x) :: r)
               end
end.

Definition g1 := [(Node 1, [Node 2; Node 3]);(Node 2, [Node 3;Node 4]); (Node 3, []);(Node 4, [])].
Compute (bfs g1).

Definition g2: list (node * list node) := [(Node 1, [])].
Compute (bfs g2).

Definition g3: list (node * list node) := [(Node 1, [Node 2]);(Node 2, []) ].
Compute (bfs g3).

Definition g4: list (node * list node) := [(Node 1, [Node 2; Node 3]);(Node 2, []) ;(Node 3,[])].
Compute (bfs g4).

Definition g5: list (node * list node) := [(Node 1, [Node 2; Node 3]);(Node 2, [Node 3;Node 4]) ;(Node 3,[Node 4; Node 5]); (Node 4, []); (Node 5, [])].
Compute bfs g5.

Definition empty_graph: list (node * list node) := [].

Compute bfs inputGraph.

Theorem bfs_computation_graph1 :
  bfs inputGraph = Some [Node 1; Node 2; Node 3; Node 4; Node 5; Node 6; Node 7; Node 8; Node 9; Node 10].
Proof.
  simpl. reflexivity. Qed.

Theorem bfs_computation_graph2 :
  bfs g1 = Some [Node 1; Node 2; Node 3; Node 4].
Proof.
  simpl. reflexivity. Qed.

Theorem bfs_computation_graph3 :
  bfs g5 = Some [Node 1; Node 2; Node 3; Node 4; Node 5].
Proof.
  simpl. reflexivity. Qed.

Theorem bfs_computation_empty_graph :
  bfs empty_graph = None.
Proof.
  simpl. reflexivity. Qed.

(*Function to convert graph to list. *)
Fixpoint convert_graph_to_list(g: list (node * list node)) :=
  match g with
  | [] => []
  | h::t => match h with
            | (x,y) => x::convert_graph_to_list t
            end
  end.

Definition remove_option_graph (g: option(list node)) :=
  match g with
  | None => []
  | Some x => x
  end.

Theorem remove_option_graph_assoc (a: node*(list node))(g: list (node * (list node)))(n: nat):
  In (Node n) (remove_option_graph (bfs (a :: g))) = In (Node n) (remove_option_graph (bfs ([a]))) \/ In (Node n) (remove_option_graph (bfs (g))).
Proof.
Admitted.

Theorem convert_assoc (a: node*(list node))(g: list (node * (list node))) : convert_graph_to_list (a :: g) = (convert_graph_to_list [a]) ++ (convert_graph_to_list g).
Proof.
Admitted.

Theorem convert_single (a: node*(list node)) :
  convert_graph_to_list [a] = [fst a].
Proof.
  Admitted.

Theorem remove_assoc (a: node * (list node)) (g: list (node * (list node))) : remove_option_graph (bfs (a :: g)) = remove_option_graph(bfs [a]) ++ remove_option_graph(bfs g).
Proof.
  Admitted.

(* Theorem to prove bfs conversion of any graph g is equivalent to all its node traversed in order of bfs. *)
Theorem bfs_comprehensive (n: node) (g: list (node * list node)) :
  convert_graph_to_list g = remove_option_graph (bfs g).
Proof.
  induction g.
  - simpl. reflexivity.
  - rewrite convert_assoc. rewrite remove_assoc. rewrite <- IHg.
    rewrite convert_single. simpl. reflexivity.
Qed.

(* Theorem to prove for every node n in graph it is also present in bfs of graph *)
Theorem bfs_node_present (n: node)(g: list (node * list node)) :
  In n (convert_graph_to_list g) -> In n (remove_option_graph (bfs g)).
Proof.
  intros. induction n.
  - induction g.
    + simpl in H. inversion H.
    + rewrite remove_assoc. simpl.  rewrite convert_assoc in H.
      rewrite convert_single in H. simpl in H. destruct H.
      * left. apply H.
      * right. apply IHg. apply H.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Coq.Relations.Relation_Definitions.
Require Import SetoidClass.
Require Import Reals.

Open Scope R_scope.

Definition operation A := A -> A -> A.

Class Associative {A : Type} (P : A -> Prop) (rel : relation A) (O : operation A) :=
 op_assoc : forall x y z, P x -> P y -> P z -> rel (O x (O y z)) (O (O x y) z).

Class Commutative {A : Type} (P : A -> Prop) (rel : relation A) (O : operation A) :=
 op_comm : forall x y, P x -> P y -> rel (O x y) (O y x).

Definition scalar A B := A -> B -> B.

Definition value A := A -> R.

Class Morphism_value {A : Type} (rel : relation A) (abs : value A) :=
 val_compat_eq : forall a a' : A, rel a a' -> (abs a) = (abs a').

Class Morphism_arit_2 {A : Type} {B : Type} (rel_a : relation A) (rel_b : relation B) (O : A -> B -> B) := {
 op_compat_eq_l : forall a a' : A, forall b : B, rel_a a a' -> rel_b (O a b) (O a' b) ;
 op_compat_eq_r : forall a : A, forall b b' : B, rel_b b b' -> rel_b (O a b) (O a b')
}.

Class Metric_Space (A : Type) (P : A -> Prop) (eqA : relation A) (d : A -> A -> R) := {
  metric_space_setoid :> Equivalence eqA ;
  metric_space_positive : forall x y : A, P x -> P y -> 0 <= d x y ;
  metric_space_symmetry : forall x y : A, P x -> P y -> d x y = d y x ;
  metric_space_separation : forall x y : A, P x -> P y -> (0 = d x y -> eqA x y) /\ (eqA x y -> 0 = d x y);
  metric_space_triangular_inequality : forall x y z : A, P x -> P y -> P z -> d x z <= (d x y) + (d y z)
}.

Class Monoid (M : Type) (P : M -> Prop) (eqM : relation M) (f : operation M) (eps : M) := {
  monoid_setoid :> Equivalence eqM ;
  monoid_eq_compat :> Morphism_arit_2 eqM eqM f ;
  monoid_contains_eps : P eps ;
  monoid_iden_l : forall x : M, P x -> eqM (f eps x) x ;
  monoid_iden_r : forall x : M, P x -> eqM (f x eps) x ;
  monoid_assoc :> Associative P eqM f
}.

Class Monoid_Commutative (M : Type) (P : M -> Prop) (eqM : relation M) (f : operation M) (eps : M) := {
  monoid_comm_monoid :> Monoid M P eqM f eps ;
  monoid_comm :> Commutative P eqM f
}.

Class Group (G : Type) (P : G -> Prop) (eqG : relation G) (f : operation G) (eps : G) := {
  group_monoid :> Monoid G P eqG f eps;
  group_reverse : forall x : G, P x -> exists y : G, (P y) /\ (eqG (f x y) eps)
}.

Class Group_Commutative (G : Type) (P : G -> Prop) (eqG : relation G) (f : operation G) (eps : G) := {
  group_comm_group :> Group G P eqG f eps ;
  group_comm :> Commutative P eqG f
}.
(*
Class Group_Multiplicative (G : Type) (eqG : relation G) (mult : operation G) (eps0 : G) (eps1 : G) := {
  group_multiplicative_setoid :> Equivalence eqG ;
  group_multiplicative_eq_compat :> Morphism_arit_2 eqG eqG mult ;
  group_multiplicative_iden_l : forall x : G, eqG (mult eps1 x) x ;
  group_multiplicative_iden_r : forall x : G, eqG (mult x eps1) x ;
  group_multiplicative_reverse : forall x : G, ~(eqG x eps0) -> exists y : G, eqG (mult x y) eps1 ;
  group_multiplicative_assoc :> Associative eqG mult
}.
*)
Class SemiRing (S : Type) (P : S -> Prop) (eqS : relation S) (add : operation S) (mult : operation S) (eps0 : S) (eps1 : S) := {
  semiring_monoid_comm :> Monoid_Commutative S P eqS add eps0 ;
  semiring_monoid :> Monoid S P eqS mult eps1 ;
  semiring_distributive_r : forall x y z : S, P x -> P y -> P z -> eqS (mult x (add y z)) (add (mult x y) (mult x z)) ;
  semiring_distributive_l : forall x y z : S, P x -> P y -> P z -> eqS (mult (add x y) z) (add (mult x z) (mult y z)) ;
  semiring_absorption_r : forall x : S, P x -> eqS (mult x eps0) eps0 ;
  semiring_absorption_l : forall x : S, P x -> eqS (mult eps0 x) eps0
}.

Class SemiRing_Commutative (S : Type) (P : S -> Prop) (eqS : relation S) (add : operation S) (mult : operation S) (eps0 : S) (eps1 : S) := {
  semiring_comm_semiring :> SemiRing S P eqS add mult eps0 eps1 ;
  semiring_comm :> Commutative P eqS mult
}.

Class Ring (R : Type) (P : R -> Prop) (eqR : relation R) (add : operation R) (mult : operation R) (eps0 : R) (eps1 : R) := {
  ring_group_comm :> Group_Commutative R P eqR add eps0 ;
  ring_monoid :> Monoid R P eqR mult eps1 ;
  ring_distributive_r : forall x y z : R, P x -> P y -> P z -> eqR (mult x (add y z)) (add (mult x y) (mult x z)) ;
  ring_distributive_l : forall x y z : R, P x -> P y -> P z -> eqR (mult (add x y) z) (add (mult x z) (mult y z))
}.

Class Ring_Commutative (R : Type) (P : R -> Prop) (eqR : relation R) (add : operation R) (mult : operation R) (eps0 : R) (eps1 : R) := {
  ring_comm_ring :> Ring R P eqR add mult eps0 eps1 ;
  ring_comm :> Commutative P eqR mult
}.

Class Field (F : Type) (P : F -> Prop) (eqF : relation F) (add : operation F) (mult : operation F) (eps0 : F) (eps1 : F) := {
  field_group_comm :> Group_Commutative F P eqF add eps0 ;
  field_group_multiplicative :> Group F (fun x:F => (P x)/\~(eqF x eps0)) eqF mult eps1 ;
  field_distributive_r : forall x y z : F, P x -> P y -> P z -> eqF (mult x (add y z)) (add (mult x y) (mult x z)) ;
  field_distributive_l : forall x y z : F, P x -> P y -> P z -> eqF (mult (add x y) z) (add (mult x z) (mult y z))
}.

Class Field_Commutative (F : Type) (P : F -> Prop) (eqF : relation F) (add : operation F) (mult : operation F) (eps0 : F) (eps1 : F) := {
  field_comm_field :> Field F P eqF add mult eps0 eps1 ;
  field_comm :> Commutative P eqF mult
}.

Class Field_Valued (F : Type) (P : F -> Prop) (eqF : relation F) (add : operation F) (mult : operation F) (eps0 : F) (eps1 : F) (abs : value F) := {
  field_valued_field_commutative :> Field_Commutative F P eqF add mult eps0 eps1 ;
  field_valued_eq_compat :> Morphism_value eqF abs ;
  field_valued_positive : forall x : F, P x -> 0 <= (abs x) ;
  field_valued_separation : (abs eps0) = 0 /\ forall x : F, P x -> (abs x) = 0 -> eqF x eps0 ;
  field_valued_triangular_inequality : forall x y : F, P x -> P y -> abs (add x y) <= (abs x) + (abs y);
  field_valued_homogeneity : forall x y : F, P x -> P y -> abs (mult x y) = (abs x) * (abs y)
}.

Class Vector_Space (E : Type) (P : E -> Prop) (eqE : relation E) (F : Type) (Q : F -> Prop) (eqF : relation F)
                                 (v_add : operation E) (v_mult : scalar F E)
                                 (add : operation F) (mult : operation F)
                                 (v_null : E)
                                 (eps0 : F) (eps1 : F):= {
  vector_space_field :> Field_Commutative F Q eqF add mult eps0 eps1 ;
  vector_space_group_comm :> Group_Commutative E P eqE v_add v_null ;
  vector_space_eq_compat :> Morphism_arit_2 eqF eqE v_mult ;
  vector_space_distributive_r : forall a : F, forall x y : E, Q a -> P x -> P y -> eqE (v_mult a (v_add x y)) (v_add (v_mult a x) (v_mult a y)) ;
  vector_space_distributive_l : forall a b : F, forall x : E, Q a -> Q b -> P x -> eqE (v_mult (add a b) x) (v_add (v_mult a x) (v_mult b x)) ;
  vector_space_assoc : forall a b : F, forall x : E, Q a -> Q b -> P x -> eqE (v_mult (mult a b) x) (v_mult a (v_mult b x)) ;
  vector_space_iden_l : forall a : F, forall x : E, Q a -> P x -> eqE (v_mult eps1 x) x
}.

Class Vector_Space_Normed (E : Type) (P : E -> Prop) (eqE : relation E) (F : Type) (Q : F -> Prop) (eqF : relation F)
                                 (v_add : operation E) (v_mult : scalar F E)
                                 (add : operation F) (mult : operation F)
                                 (v_null : E)
                                 (eps0 : F) (eps1 : F)
                                 (norm: value E) (abs : value F) := {
  vector_space_normed_field_valued :> Field_Valued F Q eqF add mult eps0 eps1 abs ;
  vector_space_normed_vector_space :> Vector_Space E P eqE F Q eqF v_add v_mult add mult v_null eps0 eps1 ;
  vector_space_normed_separation : forall v : E, P v -> (norm v) = 0 -> eqE v v_null ;
  vector_space_normed_triangular_inequality : forall v w : E, P v -> P w -> norm (v_add v w) <= (norm v) + (norm w) ;
  vector_space_normed_homogeneity : forall x : F, forall v : E, Q x -> P v -> norm (v_mult x v) = (abs x) * (norm v)
}.


(** Normalne "wektory" (czyli listy z długością znaną w czasie sprawdzania
    typów - trzeba wymyślić na nie jakąś polską nazwę) mają precyzyjnie
    określoną długość. A co jakby zamiast tego zrobić jedynie ograniczenie
    górne na długość? *)

Inductive BVec (A : Type) : nat -> Type :=
| Nil  : forall n : nat, BVec A n
| Cons : forall (h : A) {n : nat} (t : BVec A n), BVec A (S n).

Arguments Nil {A n}.
Arguments Cons {A} _ {n} _.

(** Długość musimy policzyć ręcznie, bo znamy tylko górne ograniczenie na nią. *)

Fixpoint len {A : Type} {n : nat} (v : BVec A n) : nat :=
match v with
| Nil => 0
| Cons _ t => 1 + len t
end.

Lemma bounded :
  forall {A : Type} {n : nat} (v : BVec A n),
    len v <= n.
Proof.
  induction v as [| h t]; cbn.
    apply le_0_n.
    apply le_n_S. assumption.
Qed.

(** Funkcja wyciągająca z wektora głowę musi zwracać opcję, bo nie możemy nijak
    zagwarantować za pomocą indeksu, że wektor nie jest pusty. *)

Definition head {A : Type} {n : nat} (v : BVec A n) : option A :=
match v with
| Nil => None
| Cons h _ => Some h
end.

Require Import Equality.

(** Podobnie nie możemy zagwarantować, że z wektora da się wyciągnąć jego ogon
    (bo może nie być ogona), ale w typie powinniśmy zaznaczyć, że długość naszego
    wektora jest ograniczona przez n + 1, dzięki czemu wiemy, że jeżeli już jakiś
    ogon uda się wyjąć, to jego długość będzie wynosić co najwyżej n. *)

Definition tail {A : Type} {n : nat} (v : BVec A (S n)) : option (BVec A n).
Proof.
  dependent destruction v.
    exact None.
    exact (Some v).
Defined.

(** [uncons] to połączenie [head] i [tail]. *)

Definition uncons {A : Type} {n : nat} (v : BVec A (S n)) : option (A * BVec A n).
Proof.
  dependent destruction v.
    exact None.
    exact (Some (h, v)).
Defined.

Fixpoint init {A : Type} {n : nat} (v : BVec A (S n)) : option (BVec A n).
Proof.
  dependent destruction v.
    exact None.
    dependent destruction v.
      exact (Some Nil).
Abort.

(** [take] idzie zrobić całkiem elegancko - ograniczeniem na długość jest
    minimum z dotychczasowej długości i liczby elementów, które chcemy
    zatrzymać. *)

Fixpoint take {A : Type} {n : nat} (m : nat) (v : BVec A n) : BVec A (min m n).
Proof.
  destruct m as [| m']; cbn.
    exact Nil.
    destruct v as [| h n t]; cbn.
      exact Nil.
      exact (Cons h (take _ _ m' t)).
Defined.

Require Import Arith.

(** [drop] jest jeszcze elegancksze - nowym ograniczeniem jest różnica starego i
    liczby elementów, które chcemy wyrzucić. *)

Fixpoint drop {A : Type} {n : nat} (m : nat) (v : BVec A n) : BVec A (n - m).
Proof.
  destruct m as [| m']; cbn.
    rewrite Nat.sub_0_r. exact v.
    destruct v as [| h n t]; cbn.
      exact Nil.
      exact (drop _ _ m' t).
Defined.

Fixpoint weaken {A : Type} {n : nat} (v : BVec A n) (m : nat) : BVec A (n + m) :=
match v with
| Nil => Nil
| Cons h t => Cons h (weaken t m)
end.

Fixpoint weaken' {A : Type} {n : nat} (v : BVec A n) (m : nat) : BVec A (m + n).
Proof.
refine (
match v with
| Nil => Nil
| Cons h t => _
end).
  rewrite <- plus_n_Sm. exact (Cons h (weaken' _ _ t m)).
Defined.

(** [app] *)

Fixpoint app {A : Type} {n m : nat} (v1 : BVec A n) (v2 : BVec A m) : BVec A (n + m).
Proof.
  refine (
    match v1 with
    | Nil => _
    | Cons h t => _
    end).
    exact (weaken' v2 n0).
    exact (Cons h (app _ _ _ t v2)).
Defined.

(** Poniższe funkcje nie różnią się wiele od analogicznych dla zwykłych "wektorów". *)

Fixpoint snoc {A : Type} {n : nat} (v : BVec A n) (x : A) : BVec A (S n) :=
match v with
| Nil => Cons x Nil
| Cons h t => Cons h (snoc t x)
end.

Fixpoint rev {A : Type} {n : nat} (v : BVec A n) : BVec A n :=
match v with
| Nil => Nil
| Cons h t => snoc (rev t) h
end.

Fixpoint map {A B : Type} (f : A -> B) {n : nat} (v : BVec A n) : BVec B n :=
match v with
| Nil => Nil
| Cons h t => Cons (f h) (map f t)
end.

Fixpoint join {A : Type} {n m : nat} (v : BVec (BVec A n) m)
  : BVec A (m * n) :=
match v with
| Nil => Nil
| Cons h t => app h (join t)
end.

Fixpoint repeat {A : Type} (n : nat) (x : A) : BVec A n :=
match n with
| 0 => Nil
| S n' => Cons x (repeat n' x)
end.

Fixpoint nth {A : Type} {n : nat} (m : nat) (v : BVec A n) : option A :=
match m, v with
| _   , Nil => None
| 0   , Cons h _ => Some h
| S m', Cons _ t => nth m' t
end.

Fixpoint last {A : Type} {n : nat} (l : BVec A (S n)) {struct l} : option A.
Proof.
  destruct l as [| h [| t]].
    exact None.
    exact (Some h).
    exact (last _ _ l).
Defined.


From Hammer Require Import Hammer.

Require Export FSetInterface.
Require Import DecidableTypeEx FSetFacts FSetDecide.
Set Implicit Arguments.
Unset Strict Implicit.

Hint Unfold transpose compat_op Proper respectful.
Hint Extern 1 (Equivalence _) => constructor; congruence.

Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
Module Import Dec := WDecide_fun E M.
Module Import FM := Dec.F .
Import M.

Lemma In_dec : forall x s, {In x s} + {~ In x s}.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.In_dec".
intros; generalize (mem_iff s x); case (mem x s); intuition.
Qed.

Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.

Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.Add_Equal".
unfold Add.
split; intros.
red; intros.
rewrite H; clear H.
fsetdec.
fsetdec.
Qed.

Ltac expAdd := repeat rewrite Add_Equal.

Section BasicProperties.

Variable s s' s'' s1 s2 s3 : t.
Variable x x' : elt.

Lemma equal_refl : s[=]s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.equal_refl".   fsetdec. Qed.

Lemma equal_sym : s[=]s' -> s'[=]s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.equal_sym".   fsetdec. Qed.

Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.equal_trans".   fsetdec. Qed.

Lemma subset_refl : s[<=]s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_refl".   fsetdec. Qed.

Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_trans".   fsetdec. Qed.

Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_antisym".   fsetdec. Qed.

Lemma subset_equal : s[=]s' -> s[<=]s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_equal".   fsetdec. Qed.

Lemma subset_empty : empty[<=]s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_empty".   fsetdec. Qed.

Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_remove_3".   fsetdec. Qed.

Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_diff".   fsetdec. Qed.

Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_add_3".   fsetdec. Qed.

Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_add_2".   fsetdec. Qed.

Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.in_subset".   fsetdec. Qed.

Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.double_inclusion".   intuition fsetdec. Qed.

Lemma empty_is_empty_1 : Empty s -> s[=]empty.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_is_empty_1".   fsetdec. Qed.

Lemma empty_is_empty_2 : s[=]empty -> Empty s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_is_empty_2".   fsetdec. Qed.

Lemma add_equal : In x s -> add x s [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_equal".   fsetdec. Qed.

Lemma add_add : add x (add x' s) [=] add x' (add x s).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_add".   fsetdec. Qed.

Lemma remove_equal : ~ In x s -> remove x s [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_equal".   fsetdec. Qed.

Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.Equal_remove".   fsetdec. Qed.

Lemma add_remove : In x s -> add x (remove x s) [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_remove".   fsetdec. Qed.

Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_add".   fsetdec. Qed.

Lemma singleton_equal_add : singleton x [=] add x empty.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.singleton_equal_add".   fsetdec. Qed.

Lemma remove_singleton_empty :
In x s -> remove x s [=] empty -> singleton x [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_singleton_empty".   fsetdec. Qed.

Lemma union_sym : union s s' [=] union s' s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_sym".   fsetdec. Qed.

Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_subset_equal".   fsetdec. Qed.

Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_equal_1".   fsetdec. Qed.

Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_equal_2".   fsetdec. Qed.

Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_assoc".   fsetdec. Qed.

Lemma add_union_singleton : add x s [=] union (singleton x) s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_union_singleton".   fsetdec. Qed.

Lemma union_add : union (add x s) s' [=] add x (union s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_add".   fsetdec. Qed.

Lemma union_remove_add_1 :
union (remove x s) (add x s') [=] union (add x s) (remove x s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_remove_add_1".   fsetdec. Qed.

Lemma union_remove_add_2 : In x s ->
union (remove x s) (add x s') [=] union s s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_remove_add_2".   fsetdec. Qed.

Lemma union_subset_1 : s [<=] union s s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_subset_1".   fsetdec. Qed.

Lemma union_subset_2 : s' [<=] union s s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_subset_2".   fsetdec. Qed.

Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_subset_3".   fsetdec. Qed.

Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_subset_4".   fsetdec. Qed.

Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_subset_5".   fsetdec. Qed.

Lemma empty_union_1 : Empty s -> union s s' [=] s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_union_1".   fsetdec. Qed.

Lemma empty_union_2 : Empty s -> union s' s [=] s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_union_2".   fsetdec. Qed.

Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.not_in_union".   fsetdec. Qed.

Lemma inter_sym : inter s s' [=] inter s' s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_sym".   fsetdec. Qed.

Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_subset_equal".   fsetdec. Qed.

Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_equal_1".   fsetdec. Qed.

Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_equal_2".   fsetdec. Qed.

Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_assoc".   fsetdec. Qed.

Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_inter_1".   fsetdec. Qed.

Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_inter_2".   fsetdec. Qed.

Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_add_1".   fsetdec. Qed.

Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_add_2".   fsetdec. Qed.

Lemma empty_inter_1 : Empty s -> Empty (inter s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_inter_1".   fsetdec. Qed.

Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_inter_2".   fsetdec. Qed.

Lemma inter_subset_1 : inter s s' [<=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_subset_1".   fsetdec. Qed.

Lemma inter_subset_2 : inter s s' [<=] s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_subset_2".   fsetdec. Qed.

Lemma inter_subset_3 :
s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_subset_3".   fsetdec. Qed.

Lemma empty_diff_1 : Empty s -> Empty (diff s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_diff_1".   fsetdec. Qed.

Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_diff_2".   fsetdec. Qed.

Lemma diff_subset : diff s s' [<=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.diff_subset".   fsetdec. Qed.

Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.diff_subset_equal".   fsetdec. Qed.

Lemma remove_diff_singleton :
remove x s [=] diff s (singleton x).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_diff_singleton".   fsetdec. Qed.

Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.diff_inter_empty".   fsetdec. Qed.

Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.diff_inter_all".   fsetdec. Qed.

Lemma Add_add : Add x s (add x s).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.Add_add".   expAdd; fsetdec. Qed.

Lemma Add_remove : In x s -> Add x (remove x s) s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.Add_remove".   expAdd; fsetdec. Qed.

Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_Add".   expAdd; fsetdec. Qed.

Lemma inter_Add :
In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_Add".   expAdd; fsetdec. Qed.

Lemma union_Equal :
In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_Equal".   expAdd; fsetdec. Qed.

Lemma inter_Add_2 :
~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.inter_Add_2".   expAdd; fsetdec. Qed.

End BasicProperties.

Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set.
Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym
subset_trans subset_empty subset_remove_3 subset_diff subset_add_3
subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
remove_equal singleton_equal_add union_subset_equal union_equal_1
union_equal_2 union_assoc add_union_singleton union_add union_subset_1
union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1
empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union
inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal
remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
Equal_remove add_add : set.

Lemma elements_Empty : forall s, Empty s <-> elements s = nil.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.elements_Empty".
intros.
unfold Empty.
split; intros.
assert (forall a, ~ List.In a (elements s)).
red; intros.
apply (H a).
rewrite elements_iff.
rewrite InA_alt; exists a; auto.
destruct (elements s); auto.
elim (H0 e); simpl; auto.
red; intros.
rewrite elements_iff in H0.
rewrite InA_alt in H0; destruct H0.
rewrite H in H0; destruct H0 as (_,H0); inversion H0.
Qed.

Lemma elements_empty : elements empty = nil.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.elements_empty".
rewrite <-elements_Empty; auto with set.
Qed.

Definition of_list (l : list elt) := List.fold_right add empty l.

Definition to_list := elements.

Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.of_list_1".
induction l; simpl; intro x.
rewrite empty_iff, InA_nil. intuition.
rewrite add_iff, InA_cons, IHl. intuition.
Qed.

Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.of_list_2".
unfold to_list; red; intros.
rewrite <- elements_iff; apply of_list_1.
Qed.

Lemma of_list_3 : forall s, of_list (to_list s) [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.of_list_3".
unfold to_list; red; intros.
rewrite of_list_1; symmetry; apply elements_iff.
Qed.

Section Fold.

Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) :
fold f s i = List.fold_right f i (rev (elements s)).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_spec_right".
rewrite fold_1. symmetry. apply fold_left_rev_right.
Qed.

Notation NoDup := (NoDupA E.eq).
Notation InA := (InA E.eq).

Theorem fold_rec :
forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
(forall s', Empty s' -> P s' i) ->
(forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' ->
P s' a -> P s'' (f x a)) ->
P s (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_rec".
intros A P f i s Pempty Pstep.
rewrite fold_spec_right. set (l:=rev (elements s)).
assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
P s' a -> P s'' (f x a)).
intros; eapply Pstep; eauto.
rewrite elements_iff, <- InA_rev; auto with *.
assert (Hdup : NoDup l) by
(unfold l; eauto using elements_3w, NoDupA_rev with *).
assert (Hsame : forall x, In x s <-> InA x l) by
(unfold l; intros; rewrite elements_iff, InA_rev; intuition).
clear Pstep; clearbody l; revert s Hsame; induction l.

intros s Hsame; simpl.
apply Pempty. intro x. rewrite Hsame, InA_nil; intuition.

intros s Hsame; simpl.
apply Pstep' with (of_list l); auto.
inversion_clear Hdup; rewrite of_list_1; auto.
red. intros. rewrite Hsame, of_list_1, InA_cons; intuition.
apply IHl.
intros; eapply Pstep'; eauto.
inversion_clear Hdup; auto.
exact (of_list_1 l).
Qed.

Theorem fold_rec_bis :
forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
(forall s s' a, s[=]s' -> P s a -> P s' a) ->
(P empty i) ->
(forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) ->
P s (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_rec_bis".
intros A P f i s Pmorphism Pempty Pstep.
apply fold_rec; intros.
apply Pmorphism with empty; auto with set.
rewrite Add_Equal in H1; auto with set.
apply Pmorphism with (add x s'); auto with set.
Qed.

Lemma fold_rec_nodep :
forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t),
P i -> (forall x a, In x s -> P a -> P (f x a)) ->
P (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_rec_nodep".
intros; apply fold_rec_bis with (P:=fun _ => P); auto.
Qed.

Lemma fold_rec_weak :
forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A),
(forall s s' a, s[=]s' -> P s a -> P s' a) ->
P empty i ->
(forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) ->
forall s, P s (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_rec_weak".
intros; apply fold_rec_bis; auto.
Qed.

Lemma fold_rel :
forall (A B:Type)(R : A -> B -> Type)
(f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t),
R i j ->
(forall x a b, In x s -> R a b -> R (f x a) (g x b)) ->
R (fold f s i) (fold g s j).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_rel".
intros A B R f g i j s Rempty Rstep.
rewrite 2 fold_spec_right. set (l:=rev (elements s)).
assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
(intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *).
clearbody l; clear Rstep s.
induction l; simpl; auto.
Qed.

Lemma set_induction :
forall P : t -> Type,
(forall s, Empty s -> P s) ->
(forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
forall s, P s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.set_induction".
intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
Qed.

Lemma set_induction_bis :
forall P : t -> Type,
(forall s s', s [=] s' -> P s -> P s') ->
P empty ->
(forall x s, ~In x s -> P s -> P (add x s)) ->
forall s, P s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.set_induction_bis".
intros.
apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
Qed.

Lemma fold_identity : forall s, fold add s empty [=] s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_identity".
intros.
apply fold_rec with (P:=fun s acc => acc[=]s); auto with set.
intros. rewrite H2; rewrite Add_Equal in H1; auto with set.
Qed.

Lemma fold_0 :
forall s (A : Type) (i : A) (f : elt -> A -> A),
exists l : list elt,
NoDup l /\
(forall x : elt, In x s <-> InA x l) /\
fold f s i = fold_right f i l.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_0".
intros; exists (rev (elements s)); split.
apply NoDupA_rev; auto with *.
split; intros.
rewrite elements_iff; do 2 rewrite InA_alt.
split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
apply fold_spec_right.
Qed.

Lemma fold_1 :
forall s (A : Type) (eqA : A -> A -> Prop)
(st : Equivalence eqA) (i : A) (f : elt -> A -> A),
Empty s -> eqA (fold f s i) i.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_1".
unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
rewrite H3; clear H3.
generalize H H2; clear H H2; case l; simpl; intros.
reflexivity.
elim (H e).
elim (H2 e); intuition.
Qed.

Lemma fold_2 :
forall s s' x (A : Type) (eqA : A -> A -> Prop)
(st : Equivalence eqA) (i : A) (f : elt -> A -> A),
compat_op E.eq eqA f ->
transpose eqA f ->
~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_2".
intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto with *.
rewrite <- Hl1; auto.
intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
rewrite (H2 a); intuition.
Qed.

Lemma fold_1b :
forall s (A : Type)(i : A) (f : elt -> A -> A),
Empty s -> (fold f s i) = i.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_1b".
intros.
rewrite M.fold_1.
rewrite elements_Empty in H; rewrite H; simpl; auto.
Qed.

Section Fold_More.

Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).

Lemma fold_commutes : forall i s x,
eqA (fold f s (f x i)) (f x (fold f s i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_commutes".
intros.
apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
reflexivity.
transitivity (f x0 (f x b)); auto. apply Comp; auto with *.
Qed.

Lemma fold_init : forall i i' s, eqA i i' ->
eqA (fold f s i) (fold f s i').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_init".
intros. apply fold_rel with (R:=eqA); auto.
intros; apply Comp; auto with *.
Qed.

Lemma fold_equal :
forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_equal".
intros i s; pattern s; apply set_induction; clear s; intros.
transitivity i.
apply fold_1; auto.
symmetry; apply fold_1; auto.
rewrite <- H0; auto.
transitivity (f x (fold f s i)).
apply fold_2 with (eqA := eqA); auto.
symmetry; apply fold_2 with (eqA := eqA); auto.
unfold Add in *; intros.
rewrite <- H2; auto.
Qed.

Lemma fold_empty : forall i, fold f empty i = i.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_empty".
intros i; apply fold_1b; auto with set.
Qed.

Lemma fold_add : forall i s x, ~In x s ->
eqA (fold f (add x s) i) (f x (fold f s i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_add".
intros; apply fold_2 with (eqA := eqA); auto with set.
Qed.

Lemma add_fold : forall i s x, In x s ->
eqA (fold f (add x s) i) (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_fold".
intros; apply fold_equal; auto with set.
Qed.

Lemma remove_fold_1: forall i s x, In x s ->
eqA (f x (fold f (remove x s) i)) (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_fold_1".
intros.
symmetry.
apply fold_2 with (eqA:=eqA); auto with set.
Qed.

Lemma remove_fold_2: forall i s x, ~In x s ->
eqA (fold f (remove x s) i) (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_fold_2".
intros.
apply fold_equal; auto with set.
Qed.

Lemma fold_union_inter : forall i s s',
eqA (fold f (union s s') (fold f (inter s s') i))
(fold f s (fold f s' i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_union_inter".
intros; pattern s; apply set_induction; clear s; intros.
transitivity (fold f s' (fold f (inter s s') i)).
apply fold_equal; auto with set.
transitivity (fold f s' i).
apply fold_init; auto.
apply fold_1; auto with set.
symmetry; apply fold_1; auto.
rename s'0 into s''.
destruct (In_dec x s').

transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
apply fold_init; auto.
apply fold_2 with (eqA:=eqA); auto with set.
rewrite inter_iff; intuition.
transitivity (f x (fold f s (fold f s' i))).
transitivity (fold f (union s s') (f x (fold f (inter s s') i))).
apply fold_equal; auto.
apply equal_sym; apply union_Equal with x; auto with set.
transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
apply fold_commutes; auto.
apply Comp; auto.
symmetry; apply fold_2 with (eqA:=eqA); auto.

transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))).
apply fold_2 with (eqA:=eqA); auto with set.
transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
apply Comp;auto.
apply fold_init;auto.
apply fold_equal;auto.
apply equal_sym; apply inter_Add_2 with x; auto with set.
transitivity (f x (fold f s (fold f s' i))).
apply Comp; auto.
symmetry; apply fold_2 with (eqA:=eqA); auto.
Qed.

Lemma fold_diff_inter : forall i s s',
eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_diff_inter".
intros.
transitivity (fold f (union (diff s s') (inter s s'))
(fold f (inter (diff s s') (inter s s')) i)).
symmetry; apply fold_union_inter; auto.
transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)).
apply fold_equal; auto with set.
apply fold_init; auto.
apply fold_1; auto with set.
Qed.

Lemma fold_union: forall i s s',
(forall x, ~(In x s/\In x s')) ->
eqA (fold f (union s s') i) (fold f s (fold f s' i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_union".
intros.
transitivity (fold f (union s s') (fold f (inter s s') i)).
apply fold_init; auto.
symmetry; apply fold_1; auto with set.
unfold Empty; intro a; generalize (H a); set_iff; tauto.
apply fold_union_inter; auto.
Qed.

End Fold_More.

Lemma fold_plus :
forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.fold_plus".
intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto.
Qed.

End Fold.

Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_fold".
intros; rewrite cardinal_1; rewrite M.fold_1.
symmetry; apply fold_left_length; auto.
Qed.

Lemma cardinal_0 :
forall s, exists l : list elt,
NoDupA E.eq l /\
(forall x : elt, In x s <-> InA E.eq x l) /\
cardinal s = length l.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_0".
intros; exists (elements s); intuition; apply cardinal_1.
Qed.

Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_1".
intros; rewrite cardinal_fold; apply fold_1; auto.
Qed.

Lemma cardinal_2 :
forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_2".
intros; do 2 rewrite cardinal_fold.
change S with ((fun _ => S) x).
apply fold_2; auto.
Qed.

Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_Empty".
intros.
rewrite elements_Empty, M.cardinal_1.
destruct (elements s); intuition; discriminate.
Qed.

Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_inv_1".
intros; rewrite cardinal_Empty; auto.
Qed.
Hint Resolve cardinal_inv_1.

Lemma cardinal_inv_2 :
forall s n, cardinal s = S n -> { x : elt | In x s }.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_inv_2".
intros; rewrite M.cardinal_1 in H.
generalize (elements_2 (s:=s)).
destruct (elements s); try discriminate.
exists e; auto.
Qed.

Lemma cardinal_inv_2b :
forall s, cardinal s <> 0 -> { x : elt | In x s }.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.cardinal_inv_2b".
intro; generalize (@cardinal_inv_2 s); destruct cardinal;
[intuition|eauto].
Qed.

Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.Equal_cardinal".
symmetry.
remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
induction n; intros.
apply cardinal_1; rewrite <- H; auto.
destruct (cardinal_inv_2 Heqn) as (x,H2).
revert Heqn.
rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set.
Qed.

Add Morphism cardinal with signature (Equal ==> Logic.eq) as cardinal_m.
Proof.
exact Equal_cardinal.
Qed.

Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.

Lemma empty_cardinal : cardinal empty = 0.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.empty_cardinal".
rewrite cardinal_fold; apply fold_1; auto with set.
Qed.

Hint Immediate empty_cardinal cardinal_1 : set.

Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.singleton_cardinal".
intros.
rewrite (singleton_equal_add x).
replace 0 with (cardinal empty); auto with set.
apply cardinal_2 with x; auto with set.
Qed.

Hint Resolve singleton_cardinal: set.

Lemma diff_inter_cardinal :
forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.diff_inter_cardinal".
intros; do 3 rewrite cardinal_fold.
rewrite <- fold_plus.
apply fold_diff_inter with (eqA:=@Logic.eq nat); auto.
Qed.

Lemma union_cardinal:
forall s s', (forall x, ~(In x s/\In x s')) ->
cardinal (union s s')=cardinal s+cardinal s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_cardinal".
intros; do 3 rewrite cardinal_fold.
rewrite <- fold_plus.
apply fold_union; auto.
Qed.

Lemma subset_cardinal :
forall s s', s[<=]s' -> cardinal s <= cardinal s' .
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_cardinal".
intros.
rewrite <- (diff_inter_cardinal s' s).
rewrite (inter_sym s' s).
rewrite (inter_subset_equal H); auto with arith.
Qed.

Lemma subset_cardinal_lt :
forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.subset_cardinal_lt".
intros.
rewrite <- (diff_inter_cardinal s' s).
rewrite (inter_sym s' s).
rewrite (inter_subset_equal H).
generalize (@cardinal_inv_1 (diff s' s)).
destruct (cardinal (diff s' s)).
intro H2; destruct (H2 Logic.eq_refl x).
set_iff; auto.
intros _.
change (0 + cardinal s < S n + cardinal s).
apply Plus.plus_lt_le_compat; auto with arith.
Qed.

Theorem union_inter_cardinal :
forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_inter_cardinal".
intros.
do 4 rewrite cardinal_fold.
do 2 rewrite <- fold_plus.
apply fold_union_inter with (eqA:=@Logic.eq nat); auto.
Qed.

Lemma union_cardinal_inter :
forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_cardinal_inter".
intros.
rewrite <- union_inter_cardinal.
rewrite Plus.plus_comm.
auto with arith.
Qed.

Lemma union_cardinal_le :
forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.union_cardinal_le".
intros; generalize (union_inter_cardinal s s').
intros; rewrite <- H; auto with arith.
Qed.

Lemma add_cardinal_1 :
forall s x, In x s -> cardinal (add x s) = cardinal s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_cardinal_1".
auto with set.
Qed.

Lemma add_cardinal_2 :
forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.add_cardinal_2".
intros.
do 2 rewrite cardinal_fold.
change S with ((fun _ => S) x);
apply fold_add with (eqA:=@Logic.eq nat); auto.
Qed.

Lemma remove_cardinal_1 :
forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_cardinal_1".
intros.
do 2 rewrite cardinal_fold.
change S with ((fun _ =>S) x).
apply remove_fold_1 with (eqA:=@Logic.eq nat); auto.
Qed.

Lemma remove_cardinal_2 :
forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
Proof. hammer_hook "FSetProperties" "FSetProperties.WProperties_fun.remove_cardinal_2".
auto with set.
Qed.

Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.

End WProperties_fun.

Module WProperties (M:WS) := WProperties_fun M.E M.
Module Properties := WProperties.

Module OrdProperties (M:S).
Module ME:=OrderedTypeFacts(M.E).
Module Import P := Properties M.
Import FM.
Import M.E.
Import M.

Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.sort_equivlistA_eqlistA".
apply SortA_equivlistA_eqlistA; eauto with *.
Qed.

Definition gtb x y := match E.compare x y with GT _ => true | _ => false end.
Definition leb x := fun y => negb (gtb x y).

Definition elements_lt x s := List.filter (gtb x) (elements s).
Definition elements_ge x s := List.filter (leb x) (elements s).

Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.gtb_1".
intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order.
Qed.

Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.leb_1".
intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order.
Qed.

Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.gtb_compat".
red; intros x a b H.
generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto.
intros.
symmetry; rewrite H1.
apply ME.eq_lt with a; auto.
rewrite <- H0; auto.
intros.
rewrite H0.
apply ME.eq_lt with b; auto.
rewrite <- H1; auto.
Qed.

Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.leb_compat".
red; intros x a b H; unfold leb.
f_equal; apply gtb_compat; auto.
Qed.
Hint Resolve gtb_compat leb_compat.

Lemma elements_split : forall x s,
elements s = elements_lt x s ++ elements_ge x s.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.elements_split".
unfold elements_lt, elements_ge, leb; intros.
eapply (@filter_split _ E.eq _ E.lt); auto with *.
intros.
rewrite gtb_1 in H.
assert (~E.lt y x).
unfold gtb in *; destruct (E.compare x y); intuition;
try discriminate; ME.order.
ME.order.
Qed.

Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' ->
eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.elements_Add".
intros; unfold elements_ge, elements_lt.
apply sort_equivlistA_eqlistA; auto with set.
apply (@SortA_app _ E.eq); auto with *.
apply (@filter_sort _ E.eq); auto with *.
constructor; auto.
apply (@filter_sort _ E.eq); auto with *.
rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *).
intros.
rewrite filter_InA in H1; auto with *; destruct H1.
rewrite leb_1 in H2.
rewrite <- elements_iff in H1.
assert (~E.eq x y).
contradict H; rewrite H; auto.
ME.order.
intros.
rewrite filter_InA in H1; auto with *; destruct H1.
rewrite gtb_1 in H3.
inversion_clear H2.
ME.order.
rewrite filter_InA in H4; auto with *; destruct H4.
rewrite leb_1 in H4.
ME.order.
red; intros a.
rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff,
leb_1, gtb_1, (H0 a) by auto with *.
intuition.
destruct (E.compare a x); intuition.
fold (~E.lt a x); auto with *.
Qed.

Definition Above x s := forall y, In y s -> E.lt y x.
Definition Below x s := forall y, In y s -> E.lt x y.

Lemma elements_Add_Above : forall s s' x,
Above x s -> Add x s s' ->
eqlistA E.eq (elements s') (elements s ++ x::nil).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.elements_Add_Above".
intros.
apply sort_equivlistA_eqlistA; auto with *.
apply (@SortA_app _ E.eq); auto with *.
intros.
inversion_clear H2.
rewrite <- elements_iff in H1.
apply ME.lt_eq with x; auto.
inversion H3.
red; intros a.
rewrite InA_app_iff, InA_cons, InA_nil by auto with *.
do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
Qed.

Lemma elements_Add_Below : forall s s' x,
Below x s -> Add x s s' ->
eqlistA E.eq (elements s') (x::elements s).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.elements_Add_Below".
intros.
apply sort_equivlistA_eqlistA; auto with *.
change (sort E.lt ((x::nil) ++ elements s)).
apply (@SortA_app _ E.eq); auto with *.
intros.
inversion_clear H1.
rewrite <- elements_iff in H2.
apply ME.eq_lt with x; auto.
inversion H3.
red; intros a.
rewrite InA_cons.
do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
Qed.

Lemma set_induction_max :
forall P : t -> Type,
(forall s : t, Empty s -> P s) ->
(forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
forall s : t, P s.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.set_induction_max".
intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
case_eq (max_elt s); intros.
apply X0 with (remove e s) e; auto with set.
apply IHn.
assert (S n = S (cardinal (remove e s))).
rewrite Heqn; apply cardinal_2 with e; auto with set.
inversion H0; auto.
red; intros.
rewrite remove_iff in H0; destruct H0.
generalize (@max_elt_2 s e y H H0); ME.order.

assert (H0:=max_elt_3 H).
rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
Qed.

Lemma set_induction_min :
forall P : t -> Type,
(forall s : t, Empty s -> P s) ->
(forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
forall s : t, P s.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.set_induction_min".
intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
case_eq (min_elt s); intros.
apply X0 with (remove e s) e; auto with set.
apply IHn.
assert (S n = S (cardinal (remove e s))).
rewrite Heqn; apply cardinal_2 with e; auto with set.
inversion H0; auto.
red; intros.
rewrite remove_iff in H0; destruct H0.
generalize (@min_elt_2 s e y H H0); ME.order.

assert (H0:=min_elt_3 H).
rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
Qed.

Lemma fold_3 :
forall s s' x (A : Type) (eqA : A -> A -> Prop)
(st : Equivalence eqA) (i : A) (f : elt -> A -> A),
compat_op E.eq eqA f ->
Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.fold_3".
intros.
rewrite 2 fold_spec_right.
change (f x (fold_right f i (rev (elements s)))) with
(fold_right f i (rev (x::nil)++rev (elements s))).
apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
rewrite <- distr_rev.
apply eqlistA_rev.
apply elements_Add_Above; auto.
Qed.

Lemma fold_4 :
forall s s' x (A : Type) (eqA : A -> A -> Prop)
(st : Equivalence eqA) (i : A) (f : elt -> A -> A),
compat_op E.eq eqA f ->
Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.fold_4".
intros.
rewrite 2 M.fold_1.
set (g:=fun (a : A) (e : elt) => f e a).
change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)).
unfold g.
rewrite <- 2 fold_left_rev_right.
apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
apply eqlistA_rev.
apply elements_Add_Below; auto.
Qed.

Section FoldOpt.
Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f).

Lemma fold_equal :
forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.fold_equal".
intros. rewrite 2 fold_spec_right.
apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
apply eqlistA_rev.
apply sort_equivlistA_eqlistA; auto with set.
red; intro a; do 2 rewrite <- elements_iff; auto.
Qed.

Lemma add_fold : forall i s x, In x s ->
eqA (fold f (add x s) i) (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.add_fold".
intros; apply fold_equal; auto with set.
Qed.

Lemma remove_fold_2: forall i s x, ~In x s ->
eqA (fold f (remove x s) i) (fold f s i).
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.remove_fold_2".
intros.
apply fold_equal; auto with set.
Qed.

End FoldOpt.

Lemma choose_equal : forall s s', Equal s s' ->
match choose s, choose s' with
| Some x, Some x' => E.eq x x'
| None, None => True
| _, _ => False
end.
Proof. hammer_hook "FSetProperties" "FSetProperties.OrdProperties.choose_equal".
intros s s' H;
generalize (@choose_1 s)(@choose_2 s)
(@choose_1 s')(@choose_2 s')(@choose_3 s s');
destruct (choose s); destruct (choose s'); simpl; intuition.
apply H5 with e; rewrite <-H; auto.
apply H5 with e; rewrite H; auto.
Qed.

End OrdProperties.