(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

(** * Sets built with lists *)
Add LoadPath "basis".

Set Implicit Arguments.

Require Import Relations.
Require Import List.
Require Import Setoid.
Require Import decidable_set.
Require Import more_list.
Require Import list_permut.
Require Import Arith.

Module Type S.

Declare Module Import EDS : decidable_set.ES.
Declare Module Import LP : list_permut.S with Module EDS := EDS.

Fixpoint without_red_bool (l : list A) {struct l} : bool :=
  match l with
  | nil => true
  | e :: le => if (mem_bool eq_bool e le) then false else without_red_bool le
  end.

Definition without_red l := without_red_bool l = true.

Record t : Set :=
  mk_set
  {
     support : list A;
     is_a_set : without_red support
  }.

Definition mem e s := mem eq_A e s.(support).

Definition cardinal s := List.length s.(support).

(*** Equality of sets. *)
Definition eq_set s1 s2 := forall e, mem e s1 <-> mem e s2.

Parameter eq_set_refl : forall s, eq_set s s.

Parameter eq_set_list_permut_support :
  forall s1 s2,  eq_set s1 s2 -> permut s1.(support) s2.(support).

Definition subset s1 s2 : Prop :=
  forall e, mem e s1 -> mem e s2.

Parameter cardinal_subset :
  forall s1 s2, subset s1 s2 -> cardinal s1 <= cardinal s2.

End S.

(** ** Definition of sets using lists. *)
Module Make (EDS1 : decidable_set.ES) <: S with Module EDS:= EDS1.

Module Import EDS := EDS1.

Module Import LP := list_permut.Make (EDS).

(*** Property of being without redundancy for lists of elements, intended as sets. *)
Function without_red_bool (l : list A) {struct l} : bool :=
  match l with
  | nil => true
  | e :: le => if (mem_bool eq_bool e le) then false else without_red_bool le
  end.

Definition without_red l := without_red_bool l = true.

Lemma without_red_remove :
  forall e l1 l2, without_red (l1 ++ e :: l2) -> without_red (l1 ++ l2).
Proof.
unfold without_red; fix 2.
intros e l1 l2; case l1; clear l1; simpl.
case (mem_bool eq_bool e l2); [intro H; discriminate | trivial].
intros e1 l1;
generalize (mem_bool_ok _ _ eq_bool_ok e1 (l1 ++ e :: l2)).
case (mem_bool eq_bool e1 (l1 ++ e :: l2)).
intros; discriminate.
intros e1_not_mem_l Wl.
generalize (mem_bool_ok _ _ eq_bool_ok e1 (l1 ++ l2)).
case (mem_bool eq_bool e1 (l1 ++ l2)).
intro e1_mem_l'; apply False_rec; apply e1_not_mem_l; apply mem_insert; trivial.
intro; apply (without_red_remove e l1 l2); trivial.
Qed.

Lemma without_red_not_in :
  forall e l1 l2, without_red (l1 ++ e :: l2) -> ~mem eq_A e (l1 ++ l2).
Proof.
unfold without_red; fix 2.
intros e l1 l2; case l1; clear l1; simpl.
generalize (mem_bool_ok _ _ eq_bool_ok e l2); case (mem_bool eq_bool e l2).
intros _ H _; discriminate.
intros H _; exact H.
intros e1 l1; generalize (mem_bool_ok _ _ eq_bool_ok e1 (l1 ++ e :: l2));
case (mem_bool eq_bool e1 (l1 ++ e :: l2)).
intros _ H _; discriminate.
intros e1_not_in_l1_e_l2 wr [e_eq_e1 | e_mem_l1l2]; apply e1_not_in_l1_e_l2.
rewrite <- mem_or_app; right; left; symmetry; assumption.
apply False_rec; apply (without_red_not_in e l1 l2 wr e_mem_l1l2).
Qed.

Lemma add_prf :
  forall e l1 l2, without_red (l1 ++ l2) -> ~mem eq_A e (l1 ++ l2) ->
  without_red (l1 ++ e :: l2).
Proof.
unfold without_red; fix 2.
intros e l1 l2; case l1; clear l1; simpl.
intros wr12 e_not_in_l1_l2;
generalize (mem_bool_ok _ _ eq_bool_ok e l2); case (mem_bool eq_bool e l2).
intro e_in_l2; absurd (mem eq_A e l2); assumption.
intros _; exact wr12.
intros e1 l1 wr12 e_not_in_l1_l2; generalize (mem_bool_ok _ _ eq_bool_ok e1 (l1 ++ e :: l2)).
case (mem_bool eq_bool e1 (l1 ++ e :: l2)).
intro e1_in_l1_l2;
absurd (mem eq_A e1 (l1 ++ l2)).
apply (without_red_not_in e1 nil (l1 ++ l2)); trivial.
apply diff_mem_remove with e; trivial;
intro; apply e_not_in_l1_l2; subst; left; symmetry; trivial.
intros _; apply add_prf.
apply (without_red_remove e1 nil (l1 ++ l2)); trivial.
intro; apply e_not_in_l1_l2; right; trivial.
Qed.

Lemma without_red_permut :
 forall l1 l2, without_red l1 -> LP.permut l1 l2 -> without_red l2.
Proof.
unfold without_red; fix 1.
intros l1; case l1; clear l1.
intros l2 _ P; rewrite (permut_nil (permut_sym P)); reflexivity.
intros a1 l1 l2; simpl.
generalize (mem_bool_ok _ _ eq_bool_ok a1 l1); case (mem_bool eq_bool a1 l1).
intros; discriminate.
intros a1_not_in_l1 wr1 P;assert (a1_in_l2 := cons_permut_mem (Relation_Definitions.equiv_refl _ _ eq_proof a1) P).
case (mem_split_set _ _ eq_bool_ok _ _ a1_in_l2);
intros a1' M; case M; clear M.
intros l2' M; case M; clear M.
intros l2'' M; case M; clear M.
intros a1_eq_a1' M; case M; clear M.
intros H _; subst l2.
rewrite <- permut_cons_inside in P; [idtac | exact a1_eq_a1'].
apply add_prf.
apply (without_red_permut l1); trivial.
rewrite <- (mem_permut_mem a1' P).
intro a1_in_l1; apply a1_not_in_l1.
apply (mem_eq_mem eq_proof a1' a1 l1 (equiv_sym _ _ eq_proof _ _ a1_eq_a1') a1_in_l1).
Qed.

(*** How to remove redundancies from a list with remove_red. *)
Function remove_red (l : list A) : list A :=
  match l with
  | nil => nil
  | e :: le =>
           if (mem_bool eq_bool e le)
           then remove_red le
           else e :: (remove_red le)
   end.

Lemma included_remove_red :
forall e l, mem eq_A e (remove_red l) -> mem eq_A e l.
Proof.
fix 2.
intros x l; case l; clear l.
intro H; exact H.
intros a l; simpl; case (mem_bool eq_bool a l).
intros x_in_rl; right; exact (included_remove_red x l x_in_rl).
intro x_in_arl; simpl in x_in_arl; case x_in_arl; clear x_in_arl.
intro x_eq_a; left; exact x_eq_a.
intro x_in_rl; right; exact (included_remove_red x l x_in_rl).
Qed.

Lemma remove_red_included : forall e l, mem eq_A e l -> mem eq_A e (remove_red l).
Proof.
fix 2.
intros x l; case l; clear l.
intro H; exact H.
intros a l; simpl; generalize (mem_bool_ok _ _ eq_bool_ok a l); case (mem_bool eq_bool a l).
intros a_in_l x_in_al; case x_in_al; clear x_in_al.
intro x_eq_a; apply remove_red_included.
apply (mem_eq_mem eq_proof a x l (equiv_sym _ _ eq_proof _ _ x_eq_a) a_in_l).
intro x_in_l; exact (remove_red_included x l x_in_l).
intros _ x_in_al; case x_in_al; clear x_in_al.
intro x_eq_a; left; exact x_eq_a.
intro x_in_l; right; exact (remove_red_included x l x_in_l).
Qed.

Lemma without_red_remove_red :  forall l, without_red (remove_red l).
Proof.
unfold without_red; fix 1.
intro l; case l; clear l.
reflexivity.
intros a l; simpl.
generalize (mem_bool_ok _ _ eq_bool_ok a l); case (mem_bool eq_bool a l).
intro a_in_l; apply without_red_remove_red.
intro a_not_in_l; simpl; generalize (mem_bool_ok _ _ eq_bool_ok a (remove_red l)).
case (mem_bool eq_bool a (remove_red l)).
intro a_in_rl; absurd (mem eq_A a l).
assumption.
apply included_remove_red; trivial.
intro a_not_in_rl; apply without_red_remove_red.
Qed.

(*** Definition of sets as lists without redundancy and a proof of this fact. *)
Record t : Set :=
  mk_set
  {
     support : list A;
     is_a_set : without_red support
  }.

Definition mem e s := mem eq_A e s.(support).

Lemma eq_mem_mem :
  forall s e e', eq_A e e' -> mem e s -> mem e' s.
Proof.
intros s e e' e_eq_e' e_mem_s;
destruct (mem_split_set _ _ eq_bool_ok _ _ e_mem_s) as [a [l' [l'' [e_eq_a [H _]]]]].
unfold mem; rewrite H.
rewrite <- mem_or_app; right; left.
transitivity e; trivial.
symmetry; trivial.
Qed.

Definition add (e : A) (s : t) : t.
generalize (mem_bool_ok _ _ eq_bool_ok e s.(support)).
case (mem_bool eq_bool e s.(support)).
intros _; exact s.
intros e_not_in_s.
exact (mk_set (add_prf e nil s.(support) s.(is_a_set) e_not_in_s)).
Defined.

Lemma already_mem_add : forall e s, mem e s -> add e s = s.
intros a [l prf]; unfold mem, add; simpl; generalize (mem_bool_ok _ _ EDS1.eq_bool_ok a l).
case (mem_bool EDS1.eq_bool a l).
intros; reflexivity.
intros a_not_in_l a_in_l; apply False_rec; apply a_not_in_l; assumption.
Qed.

Lemma not_already_mem_add :
  forall e s, ~ mem e s -> e :: support s = support (add e s).
intros a [l prf]; unfold mem, add; simpl; generalize (mem_bool_ok _ _ EDS1.eq_bool_ok a l).
case (mem_bool EDS1.eq_bool a l).
intros a_in_l a_not_in_l; apply False_rec; apply a_not_in_l; assumption.
intros; reflexivity.
Qed.

Lemma add_1 : forall e s, mem e (add e s).
Proof.
intros e s; unfold mem, add; simpl.
generalize (mem_bool_ok _ _ eq_bool_ok e s.(support)).
case (mem_bool eq_bool e s.(support)).
intro H; exact H.
simpl; intros _; left; reflexivity.
Qed.

Lemma add_2 : forall e e' s, mem e s -> mem e (add e' s).
Proof.
intros e e' s; unfold mem, add; simpl;
generalize (mem_bool_ok _ _ eq_bool_ok e' s.(support)).
case (mem_bool eq_bool e' s.(support)).
intros _ H; exact H.
simpl; intros _; right; assumption.
Qed.

Lemma add_12 : forall e e' s, mem e (add e' s) -> eq_A e e' \/ mem e s.
Proof.
intros e e' s; unfold mem, add; simpl;
generalize (mem_bool_ok _ _ eq_bool_ok e' s.(support)).
case (mem_bool eq_bool e' s.(support)).
intros _ H; right; assumption.
simpl; intros _ H; assumption.
Qed.

Function filter_aux (P_bool : A -> bool)  (l : list A) {struct l} : list A :=
  match l with
  | nil => nil
  | e :: le =>
           if (P_bool e)
           then e :: (filter_aux P_bool le)
           else filter_aux P_bool le
   end.

(*** Properties of filter. *)
Lemma included_filter_aux :
  forall P_bool e l,
  more_list.mem eq_A e (filter_aux P_bool l) -> more_list.mem eq_A e l.
Proof.
intros P_bool x l;
functional induction (filter_aux P_bool l)
    as [ | H1 e l H2 P_e IH | H1 e l H2 not_P_e IH ].
trivial.
intros [x_eq_e | x_in_fl]; [left | right; apply IH]; trivial.
intros  x_in_fl; right; apply IH; trivial.
Qed.

Lemma without_red_filter_aux :
  forall P_bool l, without_red l -> without_red (filter_aux P_bool l).
Proof.
unfold without_red; fix 2.
intros P_bool l; case l; clear l.
intros _; reflexivity.
simpl; intros a l.
generalize (mem_bool_ok _ _ eq_bool_ok a l); case (mem_bool eq_bool a l).
intros; discriminate.
intros a_not_in_l Wl; case (P_bool a); simpl; rewrite (without_red_filter_aux P_bool l Wl).
generalize (mem_bool_ok _ _ eq_bool_ok a (filter_aux P_bool l));
case (mem_bool eq_bool a (filter_aux P_bool l)).
intro a_in_l; absurd (more_list.mem eq_A a l).
assumption.
apply included_filter_aux with P_bool; assumption.
intros _; reflexivity.
reflexivity.
Defined.

Definition filter (P_bool : A -> bool) s
  (P_compat : forall e e', eq_A e e' -> (P_bool e = P_bool e')) :=
   mk_set (without_red_filter_aux P_bool s.(is_a_set)).

Lemma filter_1_list :
  forall (P_bool : A -> bool) l e
  (P_compat : forall e e', eq_A e e' -> (P_bool e = P_bool e')),
  more_list.mem eq_A e l -> P_bool e = true -> more_list.mem eq_A e (filter_aux P_bool l).
Proof.
intros P_bool l e P_compat e_in_l P_e;
functional induction (filter_aux P_bool l)
    as [ | H1 e' l H2 P_e' IH | H1 e' l H2 not_P_e IH ].
contradiction.
destruct e_in_l as [e_eq_e' | e_in_l]; [left | right; apply IH]; trivial.
simpl in e_in_l; destruct e_in_l as [e_eq_e' | e_in_l].
rewrite (P_compat e e') in P_e; trivial; rewrite P_e in not_P_e; discriminate.
apply IH; trivial.
Qed.

Lemma filter_1 :
  forall (P_bool : A -> bool) s P_compat e,
  mem e s -> P_bool e = true -> mem e (filter P_bool s P_compat).
Proof.
unfold mem, support;
intros P_bool [l wr] P_compat e e_in_s P_e; simpl;  apply filter_1_list; trivial.
Qed.

Lemma filter_2_list :
 forall (P_bool : A -> bool) l e
  (P_compat : forall e e', eq_A e e' -> (P_bool e = P_bool e')),
  more_list.mem eq_A e (filter_aux P_bool l) -> more_list.mem eq_A e l /\ P_bool e = true.
Proof.
intros P_bool l e P_compat H;
functional induction (filter_aux P_bool l)
    as [ | H1 e' l H2 P_e' IH | H1 e' l H2 not_P_e IH ].
contradiction.
destruct H as [e_eq_e' | e_in_fl]; split.
left; trivial.
rewrite (P_compat e e'); trivial.
right; apply (proj1 (IH e_in_fl)).
apply (proj2 (IH e_in_fl)).
split; [right | idtac]; destruct (IH H); trivial.
Qed.

Lemma filter_2 :
 forall (P_bool : A -> bool) s P_compat e,
  mem e (filter P_bool s P_compat) -> mem e s /\ P_bool e = true.
Proof.
unfold mem, support;
intros P_bool [l wr] e E e_in_l_and_P_e.
apply filter_2_list; trivial.
Qed.

(*** Empty set. *)
Lemma without_red_nil : without_red nil.
Proof.
unfold without_red; simpl; trivial.
Qed.

Definition empty : t := mk_set without_red_nil.

(*** Singleton *)
Lemma without_red_singleton : forall e : A, without_red (e :: nil).
Proof.
unfold without_red; intro e; simpl; reflexivity.
Qed.

Definition singleton (e : A) : t := mk_set (without_red_singleton e).

(*** How to build a set from a list of elements. *)
Definition make_set (l : list A) : t := mk_set (without_red_remove_red l).

(*** Union of sets. *)
Function add_without_red (acc l : list A) {struct l} : list A :=
  match l with
  | nil => acc
  | e :: le =>
     if (mem_bool eq_bool e acc)
     then add_without_red acc le
     else add_without_red (e :: acc) le
  end.

Lemma without_red_add_without_red :
  forall l1 l2, without_red l1 -> without_red (add_without_red l1 l2).
Proof.
unfold without_red;
intros l1 l2 Wl1;
functional induction (add_without_red l1 l2)
    as [ | l1 H1 e l2 H2 e_in_l1 IH | l1 H1 e l2 H2 e_not_in_l1 IH ].
assumption.
apply IH; assumption.
apply IH; simpl.
rewrite e_not_in_l1; assumption.
Qed.

Definition union s1 s2 := mk_set (without_red_add_without_red s2.(support) s1.(is_a_set)).

Lemma union_1_aux :
forall (l1 l2 : list A) (e : A), more_list.mem eq_A e l1 -> more_list.mem eq_A e (add_without_red l1 l2).
Proof.
fix 2.
intros l1 l2; case l2; clear l2.
intros; assumption.
intros a2 l2 e e_in_l1; simpl.
case (mem_bool eq_bool a2 l1).
apply (union_1_aux l1 l2 _ e_in_l1).
apply (union_1_aux (a2 :: l1) l2 _ (or_intror _ e_in_l1)).
Qed.

Lemma union_1 : forall s1 s2 e, mem e s1 -> mem e (union s1 s2).
Proof.
unfold mem; intros [l1 wr1] [l2 wr2] e; simpl; apply union_1_aux.
Qed.

Lemma union_2_aux :
forall (l1 l2 : list A) (e : A), more_list.mem eq_A e l2 -> more_list.mem eq_A e (add_without_red l1 l2).
Proof.
fix 2.
intros l1 l2; case l2; clear l2.
intros; contradiction.
intros a2 l2 e e_in_a2l2; simpl in e_in_a2l2; simpl.
case e_in_a2l2; clear e_in_a2l2.
intro e_eq_a2.
refine (mem_eq_mem eq_proof a2 e _ (equiv_sym _ _ eq_proof _ _ e_eq_a2) _); simpl.
generalize (mem_bool_ok _ _ eq_bool_ok a2 l1); case (mem_bool eq_bool a2 l1).
intro a2_in_l1; apply union_1_aux; assumption.
intros _; apply (union_1_aux (a2 :: l1) l2); left; reflexivity.
intro e_in_l2; case (mem_bool eq_bool a2 l1); apply union_2_aux; assumption.
Qed.

Lemma union_2 : forall s1 s2 e, mem e s2 -> mem e (union s1 s2).
Proof.
unfold mem; intros [l1 wr1] [l2 wr2] e; simpl; apply union_2_aux.
Qed.

Lemma union_12_aux :
forall (l1 l2 : list A) (e : A), more_list.mem eq_A e (add_without_red l1 l2) ->
       more_list.mem eq_A e l1 \/ more_list.mem eq_A e l2.
Proof.
intros l1 l2 e e_in_l1_l2;
functional induction (add_without_red l1 l2)
    as [ | l1 H1 e2 l2 H2 e2_in_l1 IH | l1 H1 e2 l2 H2 e2_not_in_l1 IH ].
left; trivial.
destruct (IH e_in_l1_l2) as [e_in_l1 | e_in_l2]; [left | do 2 right]; trivial.
destruct (IH e_in_l1_l2) as [[e_eq_e2 | e_in_l1] | e_in_l2];
[ right; left | left | do 2 right]; trivial.
Qed.

Lemma union_12 :
  forall s1 s2 e, mem e (union s1 s2) -> mem e s1 \/ mem e s2.
Proof.
unfold mem; intros [l1 wr1] [l2 wr2] e; simpl; apply union_12_aux.
Qed.

Function remove_not_common (acc l1 l2 : list A) {struct l2} : list A :=
  match l2 with
  | nil => acc
  | e :: l =>
      if (mem_bool eq_bool e l1)
      then remove_not_common (e :: acc) l1 l
      else remove_not_common acc l1 l
  end.

Lemma length_remove_not_common :
   forall l1 l2 acc, length (remove_not_common acc l1 l2) = length acc + length (remove_not_common nil l1 l2).
fix 2.
intros l1 l2 acc; case l2; clear l2; simpl.
rewrite <- plus_n_O; reflexivity.
intros a2 l2; case (mem_bool eq_bool a2 l1).
rewrite (length_remove_not_common l1 l2 (a2 :: acc));
rewrite (length_remove_not_common l1 l2 (a2 :: nil)); simpl; apply plus_n_Sm.
apply length_remove_not_common.
Qed.

Lemma without_red_remove_not_common_aux :
  forall acc l1 l2, (forall e, more_list.mem eq_A e acc /\ more_list.mem eq_A e l2 -> False) ->
                           without_red acc -> without_red l1 -> without_red l2 ->
                           without_red (remove_not_common acc l1 l2).
Proof.
intros acc l1 l2 H Wa Wl1 Wl2;
functional induction (remove_not_common acc l1 l2)
    as [
         | acc l1 H1 e l2 H2 e_in_l1 IH
         | acc l1 H1 e l2 H2 e_not_in_l1 IH].
trivial.
apply IH.
simpl; intros a H'; case H'; clear H'; intro H'; case H'; clear H'.
intros a_eq_e; revert Wl2; unfold without_red; simpl.
generalize (mem_bool_ok _ _ eq_bool_ok e l2); case (mem_bool eq_bool e l2).
intros _ Abs _; discriminate.
intros e_not_in_l2 _ e_in_l2; apply e_not_in_l2.
apply (mem_eq_mem eq_proof a); assumption.
intros a_in_acc a_in_l2; apply (H a); split; [idtac | right]; assumption.
unfold without_red; simpl.
generalize (mem_bool_ok _ _ eq_bool_ok e acc); case (mem_bool eq_bool e acc).
intro e_in_acc; apply False_rec; apply (H e); split; [assumption | left; reflexivity].
intros _; unfold without_red in Wa; assumption.
assumption.
revert Wl2; unfold without_red; simpl; case (mem_bool eq_bool e l2).
intro; discriminate.
intro; assumption.
apply IH.
simpl; intros a H'; case H'; clear H'.
intros a_in_acc a_in_l2; apply (H a); split; [idtac | right]; assumption.
assumption.
assumption.
revert Wl2; unfold without_red; simpl; case (mem_bool eq_bool e l2).
intro; discriminate.
intro; assumption.
Qed.

Lemma without_red_remove_not_common :
  forall l1 l2, without_red l1 -> without_red l2 ->
                    without_red (remove_not_common nil l1 l2).
Proof.
intros l1 l2 wr1 wr2;
apply without_red_remove_not_common_aux; trivial.
intros e [ H _ ]; contradiction.
unfold without_red; simpl; trivial.
Qed.

Definition inter s1 s2 :=
  mk_set (without_red_remove_not_common s1.(is_a_set) s2.(is_a_set)).

Lemma inter_1_aux :
  forall acc l1 l2 e, more_list.mem eq_A e (remove_not_common acc l1 l2) ->
  more_list.mem eq_A e acc \/ more_list.mem eq_A e l1.
Proof.
intros acc l1 l2 e e_in_acc_l1;
functional induction (remove_not_common acc l1 l2)
    as [
         | acc l1 H1 e2 l2 H2 e2_in_l1 IH
         | acc l1 H1 e2 l2 H2 e2_not_in_l1 IH].
left; trivial.
destruct (IH e_in_acc_l1) as [[e_eq_e2 | e_in_acc] | e_in_l1];
[ subst; right | left | right ]; trivial.
apply (mem_eq_mem eq_proof e2).
apply (equiv_sym _ _ eq_proof); assumption.
generalize (mem_bool_ok _ _ eq_bool_ok e2 l1); rewrite e2_in_l1; intro H; exact H.
apply IH; trivial.
Qed.

Lemma inter_1 : forall s1 s2 e, mem e (inter s1 s2) -> mem e s1.
Proof.
intros [l1 wr1] [l2 wr2] e H; simpl.
generalize (inter_1_aux nil l1 l2 e H).
intros [ H' | H']; trivial; contradiction.
Qed.

Lemma inter_2_aux :
  forall acc l1 l2 e, more_list.mem eq_A e (remove_not_common acc l1 l2) ->
  more_list.mem eq_A e acc \/ more_list.mem eq_A e l2.
Proof.
intros acc l1 l2 e e_in_acc_l2;
functional induction (remove_not_common acc l1 l2)
    as [
         | acc l1 H1 e2 l2 H2 e2_in_l1 IH
         | acc l1 H1 e2 l2 H2 e2_not_in_l1 IH].
left; trivial.
destruct (IH e_in_acc_l2) as [[e_eq_e2 | e_in_acc] | e_in_l1];
[ subst; right; left | left | right; right ]; trivial.
destruct (IH e_in_acc_l2) as [e_in_acc | e_in_l2]; [left | right; right]; trivial.
Qed.

Lemma inter_2 : forall s1 s2 e, mem e (inter s1 s2) -> mem e s2.
Proof.
intros [l1 wr1] [l2 wr2] e H; simpl.
generalize (inter_2_aux nil l1 l2 e H).
intros [ H' | H']; trivial; contradiction.
Qed.

Lemma inter_12_aux :
  forall acc l1 l2 e,  more_list.mem eq_A e l1 -> more_list.mem eq_A e l2 ->
  more_list.mem eq_A e (remove_not_common acc l1 l2).
Proof.
assert (H : forall acc l1 l2 e, more_list.mem eq_A e acc ->
                    more_list.mem eq_A e (remove_not_common acc l1 l2)).
intros acc l1 l2 e e_in_acc;
functional induction (remove_not_common acc l1 l2)
    as [
         | acc l1 H1 e2 l2 H2 e2_in_l1 IH
         | acc l1 H1 e2 l2 H2 e2_not_in_l1 IH].
trivial.
apply IH; right; trivial.
apply IH; trivial.

intros acc l1 l2 e e_in_l1 e_in_l2;
functional induction (remove_not_common acc l1 l2)
    as [
         | acc l1 H1 e2 l2 H2 e2_in_l1 IH
         | acc l1 H1 e2 l2 H2 e2_not_in_l1 IH].
contradiction.
destruct e_in_l2 as [e_eq_e2 | e_in_l2]; [subst; apply H; left | apply IH]; trivial.
destruct e_in_l2 as [e_eq_e2 | e_in_l2].
absurd (more_list.mem eq_A e2 l1).
generalize (mem_bool_ok _ _ eq_bool_ok e2 l1); rewrite e2_not_in_l1; intro H'; exact H'.
apply (mem_eq_mem eq_proof e); assumption.
apply IH; trivial.
Qed.

Lemma inter_12 :
  forall s1 s2 e, mem e s1 -> mem e s2 -> mem e (inter s1 s2).
Proof.
intros [l1 wr1] [l2 wr2] e e_in_l1 e_in_l2;
refine (inter_12_aux nil l1 l2 e _ _); trivial.
Qed.

(*** Subset. *)
Definition subset s1 s2 : Prop :=
  forall e, mem e s1 -> mem e s2.

Lemma subset_dec : forall s1 s2, {subset s1 s2} + {~ subset s1 s2}.
Proof.
unfold subset, mem; intros s1 s2; case s1; clear s1; simpl; intros l1 _; case s2; clear s2; simpl; intros l2 _.
revert l1 l2; fix 1.
intros l1; case l1; clear l1; simpl.
(* 1/2  l1 = [] *)
intros l2; left; intros; contradiction.
(* 1/1 l1 = _ :: _ *)
intros a1 l1 l2.
generalize (mem_bool_ok _ _ eq_bool_ok a1 l2); case (mem_bool eq_bool a1 l2).
(* 1/2 a1 in l2 *)
intro a1_in_l2; case (subset_dec l1 l2).
(* 1/3 l1 in l2 *)
intros l1_in_l2; left.
intros e e_in_a1l1; case e_in_a1l1; clear e_in_a1l1.
intro e_eq_a1; apply (mem_eq_mem eq_proof a1).
apply (equiv_sym _ _ eq_proof); assumption.
assumption.
intros e_in_l1; exact (l1_in_l2 e e_in_l1).
(* 1/2 l1 not in l2 *)
intro l1_not_in_l2; right; intro l1_in_l2; apply l1_not_in_l2.
intros e e_in_l1; exact (l1_in_l2 e (or_intror _ e_in_l1)).
(* 1/1 a1 not in l2 *)
intro a1_not_in_l2; right; intro l1_in_l2; apply a1_not_in_l2.
apply (l1_in_l2 a1); left; reflexivity.
Defined.

Lemma subset_union_1 :
  forall s1 s2, subset s1 (union s1 s2).
Proof.
intros s1 s2 e; apply union_1.
Qed.

Lemma subset_union_2 :
  forall s1 s2, subset s2 (union s1 s2).
Proof.
intros s1 s2 e; apply union_2.
Qed.

Lemma subset_inter_1 :
  forall s1 s2, subset (inter s1 s2) s1.
Proof.
intros s1 s2 e; apply inter_1.
Qed.

Lemma subset_inter_2 :
  forall s1 s2, subset (inter s1 s2) s2.
Proof.
intros s1 s2 e; apply inter_2.
Qed.

(*** Equality of sets. *)
Definition eq_set s1 s2 :=
  forall e, mem e s1 <-> mem e s2.

Lemma eq_set_dec : forall s1 s2, {eq_set s1 s2} + {~eq_set s1 s2}.
Proof.
intros s1 s2; destruct (subset_dec s1 s2) as [ s1_incl_s2 | s1_not_incl_s2 ].
destruct (subset_dec s2 s1) as [ s2_incl_s1 | s2_not_incl_s1 ].
left; intro e; intuition.
right; intro s1_eq_s2; apply s2_not_incl_s1; intros e e_in_s2;
generalize (s1_eq_s2 e); intuition.
right; intro s1_eq_s2; apply s1_not_incl_s2; intros e e_in_s1;
generalize (s1_eq_s2 e); intuition.
Qed.

Lemma eq_set_refl : forall s, eq_set s s.
Proof.
intros s e; split; trivial.
Qed.

Lemma eq_set_sym :
  forall s1 s2, eq_set s1 s2 -> eq_set s2 s1.
Proof.
intros s1 s2 H e; generalize (H e); intuition.
Qed.

Lemma eq_set_trans :
  forall s1 s2 s3, eq_set s1 s2 -> eq_set s2 s3 -> eq_set s1 s3.
Proof.
intros s1 s2 s3 s1_eq_s2 s2_eq_s3 e;
generalize (s1_eq_s2 e) (s2_eq_s3 e); intuition.
Qed.

Lemma add_compat_eq_set :
  forall e s1 s2, eq_set s1 s2 -> eq_set (add e s1) (add e s2).
Proof.
assert (forall a e s1 s2, eq_set s1 s2 -> mem a (add e s1) -> mem a (add e s2)).
intros a e s1 s2 s1_eq_s2 a_mem_e_s1.
destruct (add_12 _ _ _ a_mem_e_s1) as [a_eq_e | a_mem_s1].
assert (e_eq_a : EDS1.eq_A e a).
symmetry; trivial.
apply (eq_mem_mem (add e s2) e_eq_a).
apply add_1.
apply add_2; rewrite <- (s1_eq_s2 a); trivial.
intros e s1 s2 s1_eq_s2 a; split; apply H; trivial.
apply eq_set_sym; trivial.
Qed.

Lemma add_comm :
  forall e1 e2 s, eq_set (add e1 (add e2 s)) (add e2 (add e1 s)).
Proof.
assert (H : forall e1 e2 s, subset (add e1 (add e2 s)) (add e2 (add e1 s))).
intros e1 e2 s e; intro H.
destruct (add_12 _ _ _ H) as [e_eq_e1 | e_in_e2_s].
unfold mem; apply (mem_eq_mem eq_proof e1).
apply (equiv_sym _ _ eq_proof); assumption.
apply add_2; subst; apply add_1.
destruct (add_12 _ _ _ e_in_e2_s) as [e_eq_e2 | e_in_s].
unfold mem; apply (mem_eq_mem eq_proof e2).
apply (equiv_sym _ _ eq_proof); assumption.
apply add_1.
do 2 apply add_2; trivial.
intros e1 e2 s; split; apply H.
Qed.

Lemma union_empty_1 :
  forall s, eq_set s (union empty s).
Proof.
intros s e; generalize (union_12_aux nil (support s) e); simpl.
intuition.
apply union_2; trivial.
Qed.

Lemma union_empty_2 :
  forall s, eq_set s (union s empty).
Proof.
intros s e; simpl; intuition.
Qed.

Lemma union_comm :
  forall s1 s2, eq_set (union s1 s2) (union s2 s1).
Proof.
intros s1 s2 e;
generalize (union_12 s1 s2 e) (union_1 s1 s2 e) (union_2 s1 s2 e)
(union_12 s2 s1 e)  (union_1 s2 s1 e) (union_2 s2 s1 e); intuition.
Qed.

Lemma union_assoc :
  forall s1 s2 s3, eq_set (union s1 (union s2 s3)) (union (union s1 s2) s3).
Proof.
intros s1 s2 s3 e;
generalize (union_12 s1 (union s2 s3) e) (union_1 s1 (union s2 s3) e)
 (union_2 s1 (union s2 s3) e)
(union_12 s2 s3 e) (union_1 s2 s3 e) (union_2 s2 s3 e)
(union_12 (union s1 s2) s3 e) (union_1 (union s1 s2) s3 e)
  (union_2 (union s1 s2) s3 e)
(union_12 s1 s2 e)  (union_1 s1 s2 e) (union_2 s1 s2 e); intuition.
Qed.

Lemma subset_filter :
  forall (P1 P2 : A -> bool) s1 s2 P1_compat P2_compat,
  subset s1 s2 -> (forall e, P1 e = true -> P2 e = true) ->
  subset (filter P1 s1 P1_compat) (filter P2 s2 P2_compat).
Proof.
intros P1 P2 s1 s2 P1_compat P2_compat Hs HP e H.
apply filter_1.
apply (Hs e).
apply (proj1 (filter_2 _ _ P1_compat _ H)).
apply HP.
apply (proj2 (filter_2 _ _ P1_compat _ H)).
Qed.

Lemma filter_union :
  forall P s1 s2 P_compat,
  eq_set (filter P (union s1 s2) P_compat)
             (union (filter P s1 P_compat) (filter P s2 P_compat)).
Proof.
intros P [l1 wr1] [l2 wr2] P_compat e; split; unfold mem; simpl.
intro H; destruct (filter_2_list _  _ _ P_compat H) as [H' Pe];
destruct (union_12_aux _ _ _ H');
[ apply union_1_aux | apply union_2_aux] ; apply filter_1_list; trivial.
intro H; destruct (union_12_aux _ _ _ H) as [ H' | H'];
destruct (filter_2_list _ _ _ P_compat H') as [H'' Pe];
apply filter_1_list; trivial; [ apply union_1_aux | apply union_2_aux] ; trivial.
Qed.

Lemma subset_compat_1 :
  forall s1 s1' s2, eq_set s1 s1' -> subset s1 s2 -> subset s1' s2.
Proof.
intros s1 s1' s2 s1_eq_s1' H e e_in_s1';
apply H; generalize (s1_eq_s1' e); intuition.
Qed.

Lemma subset_compat_2 :
  forall s1 s2 s2', eq_set s2 s2' -> subset s1 s2 -> subset s1 s2'.
Proof.
intros s1 s2 s2' s2_eq_s2' H e e_in_s1;
generalize (s2_eq_s2' e) (H e e_in_s1);
intuition.
Qed.

Lemma subset_compat :
   forall s1 s1' s2 s2', eq_set s1 s1' -> eq_set s2 s2' ->
                                    subset s1 s2 -> subset s1' s2'.
Proof.
intros s1 s1' s2 s2' s1_eq_s1' s2_eq_s2' H e e_in_s1';
generalize (s1_eq_s1' e) (s2_eq_s2' e) (H e);
intuition.
Qed.

Lemma union_compat_subset_1 :
  forall s1 s2 s, subset s1 s2 -> subset (union s1 s)  (union s2 s).
Proof.
intros [l1 wr1] [l2 wr2] [l wr]; unfold subset; simpl;
intros H e e_in_ll1.
generalize (union_12_aux _ _ _ e_in_ll1); intros [ e_in_l | e_in_l1]; trivial.
apply union_1; apply H; trivial.
apply union_2; trivial.
Qed.

Lemma union_compat_subset_2 :
  forall s1 s2 s, subset s1 s2 -> subset (union s s1)  (union s s2).
Proof.
intros [l1 wr1] [l2 wr2] [l wr]; unfold subset; simpl;
intros H e e_in_ll1.
generalize (union_12_aux _ _ _ e_in_ll1); intros [ e_in_l | e_in_l1]; trivial.
apply union_1; trivial.
apply union_2; apply H; trivial.
Qed.

Lemma union_compat_subset :
  forall s1 s2 s1' s2', subset s1 s2 -> subset s1' s2' -> subset (union s1 s1')  (union s2 s2').
Proof.
intros [l1 wr1] [l2 wr2] [l1' wr1'] [l2' wr2']; unfold subset; simpl;
intros H H' e e_in_ll1.
generalize (union_12_aux _ _ _ e_in_ll1); intros [ e_in_l1 | e_in_l1'].
apply union_1; apply H; trivial.
apply union_2; apply H'; trivial.
Qed.

Lemma union_compat_eq_set :
  forall s1 s1' s2 s2', eq_set s1 s1' -> eq_set s2 s2' ->
    eq_set (union s1 s2) (union s1' s2').
Proof.
intros s1 s1' s2 s2' s1_eq_s1' s2_eq_s2' e; split; intro H.
generalize (union_12 s1 s2 e H); intros [e_in_s1 | e_in_s2].
apply union_1; generalize (s1_eq_s1' e); intuition.
apply union_2; generalize (s2_eq_s2' e); intuition.
generalize (union_12 s1' s2' e H); intros [e_in_s1' | e_in_s2'].
apply union_1; generalize (s1_eq_s1' e); intuition.
apply union_2; generalize (s2_eq_s2' e); intuition.
Qed.

Lemma  subset_subset_union :
  forall s1 s2 s, subset s1 s -> subset s2 s -> subset (union s1 s2) s.
Proof.
intros s1 s2 s H1 H2 e H.
destruct (union_12 _ _ _ H); [ apply H1 | apply H2]; trivial.
Qed.

(*** Cardinal. *)
Definition cardinal s := List.length s.(support).

Lemma cardinal_subset :
  forall s1 s2, subset s1 s2 -> cardinal s1 <= cardinal s2.
Proof.
intro s1; case s1; clear s1; intros l1 wr1.
intro s2; case s2; clear s2; intros l2 wr2.
revert l1 wr1 l2 wr2; unfold subset, cardinal, mem, without_red; simpl.
fix 1.
intro l1; case l1; clear l1.
intros _ l2 _ _; apply le_O_n.
simpl; intros a1 l1.
generalize (mem_bool_ok _ _ eq_bool_ok a1 l1); case (mem_bool eq_bool a1 l1).
intros _ Abs; discriminate.
intros a1_not_in_l1 wr1 l2 wr2 l1_in_l2.
assert (e1_in_l2 : more_list.mem eq_A a1 l2).
apply l1_in_l2; left; reflexivity.
case (mem_split_set _ _ eq_bool_ok _ _ e1_in_l2).
intros a1' M; case M; clear M.
intros l2' M; case M; clear M.
intros l2'' M; case M; clear M.
intros a1_eq_a1' M; case M; clear M.
intros H' _; subst l2.
rewrite length_add; simpl; apply le_n_S; apply cardinal_subset.
assumption.
apply (without_red_remove a1' l2' l2''); assumption.
intros e e_in_l1; apply diff_mem_remove with a1'.
intro e_eq_a1'; apply a1_not_in_l1.
apply (mem_eq_mem eq_proof a1').
apply (equiv_sym _ _ eq_proof); assumption.
apply (mem_eq_mem eq_proof e); assumption.
apply l1_in_l2; right; assumption.
Defined.

Lemma cardinal_union_1 :
  forall s1 s2, cardinal s1 <= cardinal (union s1 s2).
Proof.
intros s1 s2; apply cardinal_subset; apply subset_union_1.
Qed.

Lemma cardinal_union_2 :
  forall s1 s2, cardinal s2 <= cardinal (union s1 s2).
Proof.
intros s1 s2; apply cardinal_subset; apply subset_union_2.
Qed.

Lemma cardinal_union_inter_12 :
  forall s1 s2, cardinal (union s1 s2) + cardinal (inter s1 s2) = cardinal s1 + cardinal s2.
Proof.
intro s1; case s1; clear s1; intros l1 wr1.
intro s2; case s2; clear s2; intros l2 wr2.
revert l1 wr1 l2 wr2; unfold without_red, cardinal; simpl.
fix 3.
intros l1 wr1 l2; case l2; clear l2; simpl.
intros _; reflexivity.
intros a2 l2; generalize (mem_bool_ok _ _ eq_bool_ok a2 l2); case_eq (mem_bool eq_bool a2 l2).
intros _ _ Abs; discriminate.
intros a2_not_in_l2_bool a2_not_in_l2 wr2; generalize (mem_bool_ok _ _ eq_bool_ok a2 l1); case (mem_bool eq_bool a2 l1).
intro a2_in_l1.
rewrite length_remove_not_common; simpl.
do 2 rewrite <- plus_n_Sm; rewrite (cardinal_union_inter_12 l1 wr1 l2 wr2); reflexivity.
intro a2_not_in_l1.
rewrite <- plus_n_Sm.
rewrite <- (cardinal_union_inter_12 l1 wr1 l2 wr2).
assert (L : forall l1' l1'', length (add_without_red (l1' ++ a2 :: l1'') l2) = S (length (add_without_red (l1' ++ l1'') l2))).
clear l1 wr1 a2_not_in_l1 a2_not_in_l2 wr2; revert l2 a2 a2_not_in_l2_bool.
fix L 1.
intro l2; case l2; clear l2; simpl.
intros a2 _ l1' l1''; do 2 rewrite length_app; simpl; rewrite plus_n_Sm; reflexivity.
intros a2 l2 a; assert (eq_bool_sym : eq_bool a2 a = eq_bool a a2).
generalize (eq_bool_ok a2 a) (eq_bool_ok a a2); case (eq_bool a2 a); case (eq_bool a a2).
intros _ _; reflexivity.
intros a2_eq_a a_diff_a2; apply False_rec; apply a_diff_a2; symmetry; assumption.
intros a2_diff_a a_eq_a2; apply False_rec; apply a2_diff_a; symmetry; assumption.
intros _ _; reflexivity.
intros a_not_in_l2_bool l1' l1''; revert a_not_in_l2_bool;
rewrite (mem_bool_app eq_bool a2 l1' (a :: l1'')).
simpl; rewrite eq_bool_sym; case (eq_bool a a2); simpl.
intro; discriminate.
intro a_not_in_l2_bool; rewrite <- (mem_bool_app eq_bool a2 l1' l1'');
case (mem_bool eq_bool a2 (l1' ++ l1'')).
apply (L l2 a a_not_in_l2_bool l1' l1'').
apply (L l2 a a_not_in_l2_bool (a2 :: l1') l1'').
assert (L' := L nil l1); simpl in L'; rewrite L'; simpl; reflexivity.
Qed.

Lemma cardinal_union:
  forall s1 s2, cardinal (union s1 s2) = cardinal s1 + cardinal s2 - cardinal (inter s1 s2).
Proof.
intros s1 s2; assert (H := cardinal_union_inter_12 s1 s2).
apply plus_minus; apply sym_eq; rewrite plus_comm; trivial.
Qed.

Lemma cardinal_eq_set : forall s1 s2, eq_set s1 s2 -> cardinal s1 = cardinal s2.
Proof.
intros s1 s2 s1_eq_s2; apply le_antisym; apply cardinal_subset;
intros e e_in_si; generalize (s1_eq_s2 e); intuition.
Qed.

Lemma subset_cardinal_not_eq_not_eq_set  :
 forall s1 s2 e, subset s1 s2 -> ~mem e s1 -> mem e s2  ->
  cardinal s1 < cardinal s2.
Proof.
intro s1; case s1; clear s1; intros l1 wr1.
intro s2; case s2; clear s2; intros l2 wr2.
revert l1 wr1 l2 wr2; unfold without_red, cardinal, subset, mem; simpl.
fix 1.
intros l1 wr1 l2 wr2 a l1_in_l2 a_not_in_l1 a_in_l2.
case (mem_split_set _ _ eq_bool_ok _ _ a_in_l2);
intros a' M; case M; clear M.
intros l2' M; case M; clear M.
intros l2'' M; case M; clear M.
intros a_eq_a' M; case M; clear M.
intros M _; subst l2.
rewrite length_app; simpl (length (a' :: l2'')); rewrite <- plus_n_Sm; rewrite <- length_app.
assert (wr2' : without_red (l2' ++ l2'')).
apply without_red_remove with a'; assumption.
apply le_n_S; apply (@cardinal_subset (mk_set wr1) (mk_set wr2')).
intros e; unfold mem; simpl; intro e_in_l1.
assert (e_in_l2 := l1_in_l2 e e_in_l1).
rewrite <- mem_or_app in e_in_l2; case e_in_l2; clear e_in_l2.
intro e_in_l2'; rewrite <- mem_or_app; left; assumption.
simpl; intro e_in_l2; case e_in_l2; clear e_in_l2.
intro e_eq_a'; absurd (more_list.mem eq_A a l1).
assumption.
apply (mem_eq_mem eq_proof a').
apply (equiv_sym _ _ eq_proof); assumption.
apply (mem_eq_mem eq_proof e); assumption.
intro e_in_l2''; rewrite <- mem_or_app; right; assumption.
Qed.

Lemma eq_set_list_permut_support :
  forall s1 s2,  eq_set s1 s2 -> permut s1.(support) s2.(support).
Proof.
intros [l1 wr1] [l2 wr2]; unfold eq_set, mem; simpl;
revert l2 wr2; induction l1 as [ | e1 l1].
intros [ | e2 l2] _ H.
apply Pnil.
apply False_rec.
generalize (H e2); simpl; intros [_ Abs]; apply Abs; left; reflexivity.
intros l2 wr2 H.
assert (e1_in_l2 : more_list.mem eq_A e1 l2).
rewrite <- H; left; reflexivity; trivial.
destruct (mem_split_set _ _ eq_bool_ok _ _ e1_in_l2) as [e1' [l2' [l2'' [e1_eq_e1' [H' _]]]]].
simpl in e1_eq_e1'; simpl in H'; subst l2.
rewrite <- permut_cons_inside; trivial.
apply IHl1; trivial.
apply (without_red_remove e1 nil); trivial.
apply (without_red_remove e1'); trivial.
intros e; split; intro H'.
apply diff_mem_remove with e1'.
intro e_eq_e1'; apply (without_red_not_in e1 nil l1 wr1).
simpl; rewrite e1_eq_e1'; rewrite <- e_eq_e1'; trivial.
rewrite <- (H e); right; trivial.
apply (@diff_mem_remove _ eq_A nil l1 e1).
intro e_eq_e1; apply (without_red_not_in e1' l2' l2'' wr2).
rewrite <- e1_eq_e1'; rewrite <- e_eq_e1; trivial.
rewrite (H e); apply mem_insert; trivial.
Qed.

Lemma not_mem_compat :
 forall s2 e e', eq_A e e' ->
        (fun e0 : EDS1.A => negb (mem_bool eq_bool e0 (support s2))) e =
        (fun e0 : EDS1.A => negb (mem_bool eq_bool e0 (support s2))) e'.
Proof.
intros s2 e e' e_eq_e';
generalize (mem_bool_ok _ _ eq_bool_ok e (support s2)) (mem_bool_ok _ _ eq_bool_ok e' (support s2)).
case (mem_bool eq_bool e (support s2)); case (mem_bool eq_bool e' (support s2)).
intros _ _; reflexivity.
intros e_in_s2 e'_not_in_s2; absurd (more_list.mem eq_A e' (support s2)).
assumption.
apply (mem_eq_mem eq_proof e); assumption.
intros e_not_in_s2 e'_in_s2; absurd (more_list.mem eq_A e (support s2)).
assumption.
apply (mem_eq_mem eq_proof e').
apply (equiv_sym _ _ eq_proof); assumption.
assumption.
intros _ _; reflexivity.
Qed.

Definition set_diff s1 s2 := filter (fun e => negb (mem_bool eq_bool e s2.(support))) s1 (not_mem_compat s2).

Lemma subset_set_diff :
   forall s1 s2 s2', subset s2 s2' -> cardinal (set_diff s1 s2') <= cardinal (set_diff s1 s2).
Proof.
unfold set_diff, filter, cardinal; simpl.
intros [s1 prf]; simpl; induction s1 as [ | a1 s1]; intros s2 s2' s2_in_s2'; simpl.
apply le_n.
assert (prf1 := without_red_remove a1 nil s1 prf); simpl in prf1.
assert (H := IHs1 prf1 _ _ s2_in_s2').
set (l := filter_aux (fun e : EDS1.A => negb (mem_bool EDS1.eq_bool e (support s2))) s1) in *.
set (l' := filter_aux (fun e : EDS1.A => negb (mem_bool EDS1.eq_bool e (support s2'))) s1) in *.
generalize (s2_in_s2' a1); unfold mem.
generalize (mem_bool_ok _ _ eq_bool_ok a1 (support s2)).
generalize (mem_bool_ok _ _ eq_bool_ok a1 (support s2')).
case (mem_bool EDS1.eq_bool a1 (support s2')).
case (mem_bool EDS1.eq_bool a1 (support s2)).
intros _ _ _; assumption.
intros _ _ _; simpl; apply le_S; assumption.
case (mem_bool EDS1.eq_bool a1 (support s2)); simpl.
intros a1_not_in_s2' a1_in_s2 Sub; apply False_rec.
apply a1_not_in_s2'; apply Sub; apply a1_in_s2.
intros _ _ _; apply le_n_S; assumption.
Qed.

Lemma strict_subset_set_diff :
   forall s1 s2 s2', subset s2 s2' ->
  (exists e, mem e s1 /\ mem e s2' /\ ~mem e s2) ->
  cardinal (set_diff s1 s2') < cardinal (set_diff s1 s2).
Proof.
unfold set_diff, filter, cardinal; simpl;
intros [s1 prf]; induction s1 as [ | a1 s1];
intros s2 s2' s2_in_s2' [e [e_mem_s1 [e_mem_s2' e_not_mem_s2]]]; simpl.
contradiction.
assert (prf1 := without_red_remove a1 nil s1 prf); simpl in prf1.
generalize (eq_bool_ok e a1); case_eq (eq_bool e a1).
(* 1/2 a1 is equal to e *)
intros e_eq_a1 e_eq_a1'.
assert (a1_mem_s2' : mem_bool EDS1.eq_bool a1 (support s2') = true).
generalize (mem_bool_ok _ _ eq_bool_ok a1 (support s2')).
case (mem_bool EDS1.eq_bool a1 (support s2')).
intros _; apply refl_equal.
intro a1_not_mem_s2'; apply False_rec; apply a1_not_mem_s2'.
apply (mem_eq_mem EDS1.eq_proof e _ (support s2') e_eq_a1' e_mem_s2').
rewrite a1_mem_s2'; simpl.
assert (a1_not_mem_s2 : negb (mem_bool EDS1.eq_bool a1 (support s2)) = true).
rewrite <- (not_mem_compat s2 e_eq_a1').
generalize (mem_bool_ok _ _ eq_bool_ok e (support s2)).
case (mem_bool EDS1.eq_bool e (support s2)).
intro e_mem_s2; apply False_rec; apply e_not_mem_s2; assumption.
intros _; apply refl_equal.
rewrite a1_not_mem_s2.
simpl; apply le_n_S.
apply (subset_set_diff (mk_set prf1) s2_in_s2').
(* 1/1 a1 is different from e *)
intros e_diff_a1 e_diff_a1'.
assert (He : exists e : EDS1.A, mem e (mk_set prf1) /\ mem e s2' /\ ~ mem e s2).
exists e; repeat split; [idtac | assumption | assumption].
revert e_mem_s1; unfold mem; simpl.
intros [e_eq_a1 | e_mem_s1]; [apply False_rec; apply e_diff_a1' | idtac]; assumption.
assert (H := IHs1 prf1 _ _ s2_in_s2' He).
simpl in H.
set (l := filter_aux (fun e : EDS1.A => negb (mem_bool EDS1.eq_bool e (support s2))) s1) in *.
set (l' := filter_aux (fun e : EDS1.A => negb (mem_bool EDS1.eq_bool e (support s2'))) s1) in *.
generalize (s2_in_s2' a1); unfold mem.
generalize (mem_bool_ok _ _ eq_bool_ok a1 (support s2')); case (mem_bool EDS1.eq_bool a1 (support s2')).
generalize (mem_bool_ok _ _ eq_bool_ok a1 (support s2)); case (mem_bool EDS1.eq_bool a1 (support s2)).
intros _ _ _; assumption.
intros _ _ _; simpl; apply le_S; assumption.
generalize (mem_bool_ok _ _ eq_bool_ok a1 (support s2)); case (mem_bool EDS1.eq_bool a1 (support s2)).
intros a1_in_s2 a1_not_in_s2' Sub; apply False_rec.
apply a1_not_in_s2'; apply Sub; apply a1_in_s2.
intros _ _ _; simpl; apply le_n_S; assumption.
Qed.

End Make.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../basis/" "-I" "../list_extensions/") ***
*** End: ***
 *)


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** A library of code for supporting LNgen. *)

Require Export Metalib.LibDefaultSimp.
Require Import Metalib.Metatheory.
Require Import Omega.

(* ********************************************************************** *)
(** * Assorted functions not in the standard library *)

(** [lt_ge_dec] is a useful comparison operation when defining the
    "close" operation on locally nameless terms. *)

Definition lt_ge_dec (n m : nat) : {n < m} + {n >= m} :=
  match Compare_dec.le_gt_dec m n with
    | left pf => right pf
    | right pf => left pf
  end.

(* *********************************************************************** *)
(** * Tactics *)

(** [generalize_wrt x] is an ad hoc tactic that generalizes the goal
    with respect to everything that [x] does not depend on.  It seems
    to work only if [x] is the most recently introduced item into the
    context. *)

Ltac generalize_wrt x :=
  repeat (progress (match goal with
    | J : _ |- _ => move J after x; generalize dependent J
    end)).

(** [apply_mutual_ind] applies to the current goal a mutual induction
    principle that is stated in the form generated by [Combined
    Scheme].  It works even in degenerate cases, i.e., when there is
    no mutual induction, only simple induction.  It is intended to be
    used only at the start of a proof, and the argument(s) to induct
    over should come first. *)

Ltac apply_mutual_ind ind :=
  match goal with
     [ |- (and _ _) ]  => apply ind
   | [ |- (prod _ _) ]  => apply ind
   | _ =>
     let H := fresh in
     first [ (* apply ind
        | *) intros H; induction H using ind
        | intros ? H; induction H using ind
        | intros ? ? H; induction H using ind
        | intros ? ? ? H; induction H using ind
        | intros ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? ? ? H; induction H using ind
        ]
     end.

(** Renames the last hypothesis to the given identifier. *)

Ltac rename_last_into H :=
  match goal with
    | J : _ |- _ => rename J into H
  end.

(** Specializes every possible hypothesis with the given term. *)

Ltac specialize_all x :=
  repeat (match goal with
            | H : _ |- _ => specialize (H x)
          end).

(* *********************************************************************** *)
(** * Facts about finite sets *)

Lemma remove_union_distrib : forall (s1 s2 : atoms) (x : atom),
  remove x (union s1 s2) [=] union (remove x s1) (remove x s2).
Proof. fsetdec. Qed.

Lemma Equal_union_compat : forall (s1 s2 s3 s4 : atoms),
  s1 [=] s3 ->
  s2 [=] s4 ->
  union s1 s2 [=] union s3 s4.
Proof. fsetdec. Qed.

Lemma Subset_refl : forall (s : atoms),
  s [<=] s.
Proof. fsetdec. Qed.

Lemma Subset_empty_any : forall (s : atoms),
  empty [<=] s.
Proof. fsetdec. Qed.

Lemma Subset_union_compat : forall (s1 s2 s3 s4 : atoms),
  s1 [<=] s3 ->
  s2 [<=] s4 ->
  union s1 s2 [<=] union s3 s4.
Proof. fsetdec. Qed.

Lemma Subset_union_left : forall (s1 s2 s3 : atoms),
  s1 [<=] s2 ->
  s1 [<=] union s2 s3.
Proof. fsetdec. Qed.

Lemma Subset_union_right : forall (s1 s2 s3 : atoms),
  s1 [<=] s3 ->
  s1 [<=] union s2 s3.
Proof. fsetdec. Qed.

Lemma Subset_union_lngen_open_upper :
  forall (s1 s2 s3 s4 s5 : atoms),
  s1 [<=] union s3 s4 ->
  s2 [<=] union s3 s5 ->
  union s1 s2 [<=] union s3 (union s4 s5).
Proof. fsetdec. Qed.

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

Hint Resolve sym_eq : brute_force.

Hint Extern 5 (_ = _ :> nat) => omega : brute_force.
Hint Extern 5 (_ < _)        => omega : brute_force.
Hint Extern 5 (_ <= _)       => omega : brute_force.

Hint Rewrite @remove_union_distrib : lngen.

Hint Resolve @Equal_union_compat : lngen.
Hint Resolve @Subset_refl : lngen.
Hint Resolve @Subset_empty_any : lngen.
Hint Resolve @Subset_union_compat : lngen.
Hint Resolve @Subset_union_left : lngen.
Hint Resolve @Subset_union_right : lngen.
Hint Resolve @Subset_union_lngen_open_upper : lngen.


Require Import TErrorMonad Showable Decidable HoTT PartialOrder.

Set Universe Polymorphism.

(** ** Monotone type-theoretic Galois connection *)

(* =IsPartialEquiv= *)
Class IsConnection {A B} `{IsPartialOrder_pp A} `{IsPartialOrder_pp B}
      (f: A --> B) := {
    c_inv:  B --> A;
    c_sect: id ≼  c_inv ° f ;
    c_retr: f ° c_inv ≼ id;
}.
(* =end= *)

Arguments c_inv {_ _ _ _} _ {_}.
Arguments c_sect {_ _ _ _} _ {_} _.
Arguments c_retr {_ _ _ _} _ {_} _.

(* =CanonicalPartialEquiv= *)
Class Connection A B `{IsPartialOrder_pp A} `{IsPartialOrder_pp B} := {
    c_fun: A --> B ;
    c_isconn:> IsConnection c_fun
}.
Notation "A ≲ B" := (Connection A B)
(* =end= *)
                       (at level 20).

(* =IsConnectionIsHProp= *)
Instance IsConnectionIsHProp A B
         `{IsPartialOrder_pp A}`{IsPartialOrder_pp B}(f: A --> B):
           IsHProp (IsConnection f).
(* =end= *)
Proof.
  intros g g'. destruct g, g'.
  assert (c_inv0 = c_inv1).
  {
    destruct c_inv0, c_inv1.
    assert (f_ord = f_ord0).
    {
      apply rel_antisym.
      - intro x. eapply rel_trans. apply c_sect1. simpl. apply mon0. apply c_retr0.
      - intro x. eapply rel_trans. apply c_sect0. simpl. apply mon. apply c_retr1.
    }
    subst.
    assert (mon = mon0) by apply is_hprop.
    assert (p_mon = p_mon0) by apply is_hprop.
    subst. reflexivity.
  }
  subst.
  assert (c_sect0 = c_sect1) by apply is_hprop.
  assert (c_retr0 = c_retr1) by apply is_hprop.
  subst. reflexivity.
Defined.

(** ** Monotone type-theoretic partial Galois connection  *)

(**

A monotone function [f: A → B] defines a partial coercion
[PartialConnection] if some of the [b: B] maps back to the same [a: A]
they come from. Think of [A] as being a refinement of [B] and [f] as
dropping the refinement: not all [B]'s are valid [A]'s but the one
which are can easily be mapped back to [A].

 *)

(* =IsPartialEquivK= *)
Class IsConnectionK {A B: HSet} (f: A ⇀ B) := {
    pc_inv:  B ⇀ A;
    pc_sect: creturn ≼ pc_inv °° f;
    pc_retr: f °° pc_inv ≼ creturn ;
}.
(* =end= *)

Arguments pc_inv {_ _} _ {_}.
Arguments pc_sect {_ _} _ {_} _.
Arguments pc_retr {_ _} _ {_} _.

(* =PartialEquivK= *)
Record ConnectionK (A B: HSet) := {
  pc_fun: A ⇀ B ;
  pc_isconn: IsConnectionK pc_fun
}.
Notation "A ≲K B" := (ConnectionK A B)
(* =end= *)
                        (at level 20).

Arguments pc_fun {_ _} _ _.
Arguments pc_isconn {_ _ _}.

(* =IsPartialEquiv= *)
Class IsAnticonnection {A B}
      `{IsPartialOrder_pp A} `{IsPartialOrder_pp B} (f: A --> B) := {
    ac_inv:  B --> A;
    ac_sect: ac_inv ° f ≼ id ;
    ac_retr: f ° ac_inv ≼ id;
}.
(* =end= *)

Arguments ac_inv {_ _ _ _} _ {_}.
Arguments ac_sect {_ _ _ _} _ {_} _.
Arguments ac_retr {_ _ _ _} _ {_} _.

(* =CanonicalPartialEquiv= *)
Class Anticonnection A B `{IsPartialOrder_pp A} `{IsPartialOrder_pp B} :=
  {  ac_fun: A --> B ;
     ac_isconn:> IsAnticonnection ac_fun
  }.
Notation "A ≈ B" := (Anticonnection A B)
(* =end= *)
                       (at level 20).

(* =IsAPartialEquivK= *)
Class IsAnticonnectionK {A B: HSet} (f: A ⇀ B) :=
  { apc_inv:  B ⇀ A;
    apc_sect: apc_inv °° f ≼ creturn;
    apc_retr: f °° apc_inv ≼ creturn ;
}.
(* =end= *)

Arguments apc_inv {_ _} _ {_}.
Arguments apc_sect {_ _} _ {_} _.
Arguments apc_retr {_ _} _ {_} _.

(* =APartialEquivK= *)
Record AnticonnectionK (A B: HSet) := {
  apc_fun: A ⇀ B ;
  apc_isconn: IsAnticonnectionK apc_fun
}.
Notation "A ≈K B" := (AnticonnectionK A B)
(* =end= *)
                        (at level 20).

Arguments apc_fun {_ _} _ _.
Arguments apc_isconn {_ _ _}.

(**
  Sanity Check: lifting an equivalance yields
  a partial equivalence in the Kleisli category
*)

Ltac etransitivity := eapply concat.

(* =EquivToPartialEquivK= *)
Definition EquivToConnectionK (A B: HSet) (f: A -> B) :
  IsEquiv f -> IsConnectionK (clift f).
(* =end= *)
Proof.
  intro H.
  simple refine (Build_IsConnectionK _ _ _ (clift (e_inv f)) _ _).
  - intro x. exact (HoTT.ap Some (e_sect f x))^.
  - intro x. exact (HoTT.ap Some (e_retr f x)).
Defined.

(**

we have a subset equivalence between [B] and [{C,P}]
if the type family [B] is isomorphic with a (computationally-relevant)
type [C] and a (computationally-irrelevant) relation [P], ie.

<<
     [B a ≅ { c : C & P a c }]
>>

Remarks:
 - [C] is non-dependent in [a : A], by definition.

 - Usually, [A] plays the role of the indices, [B] is an inductive
   family indexed over [A]. [C] are the "raw", computational terms
   while [P] is a validity predicate.

*)

(* conversion between coercion and anticoercion *)

(* =Coercion_AntiCoercion= *)
Definition Connection_Anticonnection (A B: HSet) : A ≲K B -> A ≈K B.
(* =end= *)
Proof.
  intro H; unshelve econstructor.
  - exact (pc_fun H).
  - unshelve econstructor.
    + refine (pc_inv (pc_fun H)). exact pc_isconn.
    + intro a. pose (foo := @pc_sect _ _ (pc_fun H) pc_isconn a). cbn in *.
      clearbody foo. revert foo.
      destruct ((pc_inv (pc_fun H)) °° (pc_fun H) a). symmetry. exact foo.
      intro; exact I.
    + exact (pc_retr (pc_fun H)).
Defined.

Instance Connection_IsAnticonnectionK (A B: HSet)
  (H : A ≈K B) : IsAnticonnectionK (apc_fun H) := apc_isconn.

(* =AntiCoercion_Coercion= *)
Definition Anticonnection_Connection (A B: HSet) (H : A ≈K B):
           creturn ≼ (apc_inv (apc_fun H)) °° (apc_fun H) -> A ≲K B.
(* =end= *)
Proof.
  intro H'; unshelve econstructor.
  - exact (apc_fun H).
  - unshelve econstructor.
    + exact (apc_inv (apc_fun H)).
    + exact H'.
    + exact (apc_retr (apc_fun H)).
Defined.

Instance Connection_Anticonnection_K (A B: Type)
         `{IsPartialOrder_pp A} `{IsPartialOrder_pp B}
         (H : A ≈ B) (H' : id ≼ (ac_inv ac_fun) ° (@ac_fun _ _ _ _ H)) :
  A ≲ B.
Proof.
  destruct H1; unshelve econstructor; try solve [auto].
  destruct ac_isconn; unshelve econstructor; try solve [auto].
Defined.

Instance Anticonnection_Connection_K (A B: Type)
         `{IsPartialOrder_pp A} `{IsPartialOrder_pp B}
         (H : A ≲ B) (H' : (c_inv c_fun) ° (@c_fun _ _ _ _ H) ≼ id ) :
  A ≈ B.
Proof.
  destruct H1; unshelve econstructor; try solve [auto].
  destruct c_isconn; unshelve econstructor; try solve [auto].
Defined.

Notation "{ x : A & P }" := (sigT_HSet A (fun x => P)) : type_scope.

(* =to_subset= *)
Definition to_subset {C: HSet} {P} `{forall c, Checkable (P c)}: C ⇀ ({c:C & P c})
  := fun c =>
       match dec (check (P c)) with
       | inl p => Some (c; convert p)
       | inr _ => Fail (_with ("subset conversion"))
       end.
(* =end= *)

Instance Checkable_IsAnticonnectionK (C: HSet) P `{forall c, Checkable (P c)}:
  IsAnticonnectionK (clift π1: {c: C & P c} ⇀ C).
Proof.
  unshelve refine ({| apc_inv := to_subset |}).
  - intro c. unfold kleisliComp.
    unfold to_subset in *. simpl.
    destruct dec; simpl;
      [
      | eauto ].
    simpl. unfold creturn. apply HoTT.ap. refine (path_sigma_uncurried _ _ _ _).
    exists eq_refl. apply is_hprop.
  - intro c. unfold kleisliComp.
    unfold to_subset in *.
    destruct (dec); simpl;
      [ |  eauto].
    reflexivity.
Defined.

(* =Checkable_AntiPartialEquivK= *)
Definition Checkable_AnticonnectionK  (C:HSet) P `{forall c, Checkable (P c)}:
  {c:C & P c} ≈K C :=
  {| apc_fun :=  clift π1 : {c:C & P c} ⇀ C |}.
(* =end= *)

(* =Decidable_ConnectionK= *)
Definition Decidable_ConnectionK  (C:HSet) P `{forall c, Decidable (P c)}:
  {c:C & P c} ≲K C.
(* =end= *)
Proof.
  unshelve eapply Anticonnection_Connection.
  - apply Checkable_AnticonnectionK; typeclasses eauto.
  - intro c. unfold kleisliComp.
    cbn. unfold to_subset in *. simpl.
    destruct dec; simpl;
      [
      | eauto ].
    simpl. unfold creturn. apply HoTT.ap. refine (path_sigma_uncurried _ _ _ _).
    exists eq_refl. apply is_hprop.
    destruct (n c.2).
Defined.

(** ** Injective functions *)

(** This class is particularly useful to reflect constructors and take
advantage of their injectivity *)

(* =IsInjective= *)
Class IsInjective {A B: HSet} (f: A -> B) := {
    i_inv: B ⇀ A;
    i_sect: i_inv ° f == creturn ;
    i_retr: (clift f) °° i_inv ≼ creturn
}.
(* =end= *)

Notation "f ^?-1" := (@i_inv _ _ f _) (at level 3, format "f '^?-1'").

Instance Injective_comp {A B C : HSet}
         (f : A -> B) (g : B -> C)
         `{IsInjective A B f} `{IsInjective B C g}:
  IsInjective (g ° f)
  := {| i_inv := (f^?-1 °° (g^?-1)) |}.
Proof.
  - unfold compose, kleisliComp. intro a.
    pose (i_sect (f:=g) (f a)). unfold compose in e.
    rewrite e.
    exact (i_sect (f:=f) a).
  - intros c. cbn.
    pose (r := i_retr (f:=g) c).
    unfold compose, kleisliComp in *.
    cbn in *.
    generalize dependent r. destruct (g^?-1 c) as [b|]; cbn in *; [| eauto].
    pose (r := i_retr (f:=f) b).
    unfold compose, kleisliComp in *.
    generalize dependent r. destruct (f^?-1 b); cbn in *; [| eauto].
    unfold clift. intros.
    apply HoTT.ap.
    inversion r0. inversion r. auto.
Defined.

(** *** Instances of IsInjective *)

(** The identity is an injection : *)
Definition IsInjective_id {A:HSet}: IsInjective (fun x:A => x).
Proof.
  simple refine (Build_IsInjective _ _ _ (@Some A _) _ _).
  intro a. reflexivity.
  intros a. reflexivity.
Defined.

(** The predecessor over natural numbers is a partial equivalence: *)

Definition S_inv (n: nat) :=
  match n with
    | O => Fail (_with "invalid index")
    | S n' => Some n'
  end.

Instance IsInjective_S: @IsInjective Hnat Hnat S :=
  {| i_inv := S_inv : Hnat ⇀ Hnat |}.
Proof.
  intro a. reflexivity.
  intros n. destruct n; cbn in *; eauto.
Defined.


Require Import Ctl.BinaryRelations.
Require Import Ctl.Paths.
Require Import Ctl.Definition.
Require Import Ctl.Basic.
Require Import Ctl.Tactics.

Require Import Glib.Glib.
Require Import Lia.

Section Properties.
Open Scope tprop_scope.

Context {state: Type}.
Context (R: relation state).
Context {t: transition R}.

(* Properties of implication *)

Theorem timpl_refl : forall (s: state) a,
  R @s ⊨ a ⇾ a.
Proof using.
  intros.
  tintro.
  assumption.
Qed.

Theorem timpl_trans : forall (s: state) a b c,
  R @s ⊨ (a ⇾ b) ⇾ (b ⇾ c) ⇾ a ⇾ c.
Proof using.
  intros s a b c.
  tintros Hab Hbc Ha.
  tapplyc Hbc.
  tapplyc Hab.
  assumption.
Qed.

Theorem timpl_trans' : forall (s: state) a b c,
  R @s ⊨ a ⇾ b ->
  R @s ⊨ b ⇾ c ->
  R @s ⊨ a ⇾ c.
Proof using.
  intros s a b c Hab Hbc.
  tintros Ha.
  tapplyc Hbc.
  tapplyc Hab.
  assumption.
Qed.

Ltac treflexivity := simple apply timpl_refl.
Ltac treflexive :=
  match goal with
  | |- _ @_ ⊨ ?a ⇾ ?a => treflexivity
  | |- _ @_ ⊨ ?a ⇾ ?b =>
      replace a with b;
        [ treflexivity
        | try easy; symmetry
        ]
  end.

Ltac ttransitivity x :=
  match goal with
  | |- ?R @?s ⊨ ?a ⇾ ?b =>
      simple apply (timpl_trans' R s a x b)
  end.

Ltac ettransitivity :=
  match goal with
  | |- ?R @?s ⊨ ?a ⇾ ?b =>
      simple eapply (timpl_trans' R s a _ b)
  end.

Theorem textensionality : forall s P Q,
  R @s ⊨ P ⇿ Q ->
  (R @s ⊨ P) = (R @s ⊨ Q).
Proof using.
  intros.
  extensionality.
  assumption.
Qed.

Lemma tNNPP : forall s P,
(* TODO: fix precedence so parantheses not necessary *)
  R @s ⊨ (!!P) ⇾ P.
Proof using.
  intros *.
  tintro H.
  now apply NNPP.
Qed.

Lemma rew_tNNPP : forall s P,
  (R @s ⊨ !!P) = (R @s ⊨ P).
Proof using.
  intros *.
  extensionality.
  split.
  - tapply tNNPP.
  - intro.
    tintro contra.
    now tapply contra.
Qed.

(* Properties of CTL path-quantifying formulas *)

Theorem star__AG : forall s P,
  (forall s', R^* s s' -> R @s' ⊨ P) ->
  R @s ⊨ AG P.
Proof using.
  intros * H.
  tsimpl.
  intros * Hin.
  applyc H.
  follows eapply in_path_star.
Qed.

Theorem AG__star : forall s P,
  R @s ⊨ AG P ->
  forall s', R^* s s' -> R @s' ⊨ P.
Proof using.
  intros * H * Hstar.
  apply star_in_path in Hstar as [p Hin].
  follows etapply H.
Qed.

Theorem rew_AG_star : forall s P,
  R @s ⊨ AG P =
    forall s', R^* s s' -> R @s' ⊨ P.
Proof using.
  intros *.
  extensionality.
  split.
  - now apply AG__star.
  - apply star__AG.
Qed.

Theorem star__EF : forall s P,
  (exists s', R^* s s' /\ R @s' ⊨ P) ->
  R @s ⊨ EF P.
Proof using.
  intros * H.
  tsimpl.
  destruct H as (s' & Hstar & H).
  apply star_in_path in Hstar as [p Hin].
  tedious.
Qed.

Theorem EF__star : forall s P,
  R @s ⊨ EF P ->
  exists s', R^* s s' /\ R @s' ⊨ P.
Proof using.
  intros * H.
  tsimpl in H.
  destruct H as (p & s' & Hin & H).
  exists s'.
  split.
  - follows eapply in_path_star.
  - assumption.
Qed.

Theorem rew_EF_star : forall s P,
  R @s ⊨ EF P =
    exists s', R^* s s' /\ R @s' ⊨ P.
Proof using.
  intros *.
  extensionality.
  split.
  - follows apply EF__star.
  - apply star__EF.
Qed.

Theorem AU_trivial : forall s P Q,
  R @s ⊨ Q ⇾ A[P U Q].
Proof using.
  intros *.
  tintro H.
  tsimpl.
  intros.
  exists 0.
  split.
  - intros * Hin_before.
    follows inv Hin_before.
  - follows rewrite state_at_0.
Qed.

Lemma ex_first_sat_index : forall s (p: path R s) P i,
  R @(p i) ⊨ P ->
  exists j,
    R @(p j) ⊨ P /\
    forall x, in_path_before x j p -> R @x ⊨ !P.
Proof using.
  intros * Hi.
  cut (forall j,
    j <= i ->
    (forall x, in_path_before x (S j) p -> R @x ⊨ !P) \/
      exists k,
        k <= j /\
        R @(p k) ⊨ P /\
        (forall x, in_path_before x k p -> R @x ⊨ !P)
  ).
  - intro H.
    specialize (H i).
    forward H by tedious.
    destruct H.
    + contradict Hi.
      follows tapply H.
    + tedious.
  - intro j; induction j.
    + intros _.
      destruct classic (R @(p 0) ⊨ P) as case.
      * follows right.
      * left.
        intros ? (j & jlt & <-).
        after destruct j.
        follows inv jlt.
    + intros sjlt.
      forward IHj by lia.
      destruct IHj as [H|H].
      * destruct classic (R @(p (S j)) ⊨ P) as case.
       -- follows right.
       -- left.
          intros x (k & klt & pkx).
          transform klt (k = S j \/ k < S j) by lia.
          destruct klt; subst!.
         ++ assumption.
         ++ follows apply H.
      * right.
        destruct H as (k & ?).
        follows exists k.
Qed.

Corollary earliest_ex : forall s (p: path R s) P,
  (exists s', in_path s' p /\ R @s' ⊨ P) ->
  exists i,
    (forall x, in_path_before x i p -> R @x ⊨ !P) /\
    R @(p i) ⊨ P.
Proof using.
  intros * (s' & [i <-] & H).
  follows apply ex_first_sat_index in H.
Qed.

Definition AW_seq s P Q :=
  R @s ⊨ P || Q /\
  forall s' (seq: R#* s s'),
    (forall x, in_seq x seq -> R @x ⊨ P && !Q) ->
    forall s'',
      R s' s'' ->
      R @s'' ⊨ P || Q.

(* Should likely use `AW_in_before_nQ` instead *)
Theorem AW_seq_nQ : forall s P Q s' (seq: R#* s s'),
  AW_seq s P Q ->
  (forall x, in_seq x seq -> R @x ⊭ Q) ->
  forall x, in_seq x seq -> R @x ⊨ P.
Proof using.
  intros * [Hs HAW] HnQ x Hin.
  transform Hs (R @s ⊨ P).
  { after destruct or Hs.
    contradict Hs.
    apply HnQ.
    apply in_seq_first.
  }
  apply in_seq__in_seq_at in Hin as [i Hin].
  revert x Hin;
    wf_induction i lt;
    intros x Hin.
  destruct i.
  - follows apply inv_in_seq_at_0 in Hin as ->.
  - pose proof (ex_in_seq_at_le_length R seq i) as Hin'.
    forward Hin'.
    { after transitivity (S i).
      follows eapply in_seq_at_length.
    }
    destruct exists Hin' w.
    pose proof (in_seq_at_succ_related R seq) as HR.
    do 3 especialize HR;
      specialize (HR Hin' Hin).
    epose proof (ex_seq_at_prefix R seq i Hin') as prefix.
    destruct prefix as (prefix & prefix_length & Hprefix).
    specialize (HAW w prefix).
    forward HAW.
    { intros * Hin_prefix.
      apply in_seq__in_seq_at in Hin_prefix as [j Hin_prefix].
      assert (R @x0 ⊭ Q).
      { apply HnQ.
        follows eapply in_seq_at__in_seq.
      }
      constructor; [ |follows tsimpl].
      after apply wfIH with (y := j).
      apply in_seq_at_length in Hin_prefix.
      lia.
    }
    specialize (HAW x HR).
    after destruct or HAW.
    contradict HAW.
    apply HnQ.
    follows eapply in_seq_at__in_seq.
Qed.
(* Print Assumptions AW_seq_nQ. *)

Theorem AW_in_before_nQ : forall s P Q (p: path R s) i,
  AW_seq s P Q ->
  (forall x, in_path_before x i p -> R @x ⊭ Q) ->
  forall x, in_path_before x i p -> R @x ⊨ P.
Proof using.
  intros * [Hs HAW] HnQ x Hin.
  transform Hs (R @s ⊨ P).
  { after destruct or Hs.
    contradict Hs.
    apply HnQ.
    exists 0.
    split.
    - destruct i.
      + exfalso. inv Hin; lia.
      + lia.
    - apply state_at_0.
  }
  revert x Hin;
    wf_induction i lt;
    intros x Hin.
  destruct i.
  - exfalso. inv Hin; lia.
  - destruct Hin as (j & jlt & <-).
    destruct j; [follows rewrite state_at_0| ].
    specialize (HAW (p j) (prefix R p j)).
    forward HAW.
    + intros * Hin.
      apply inv_in_prefix in Hin.
      constructor.
      * after apply (wfIH (S j)).
        intros.
        apply HnQ.
        follows eapply in_path_before_grow.
      * tsimpl.
        apply HnQ.
        follows eapply in_path_before_grow.
    + specialize (HAW (p (S j))).
      forward HAW by follows repeat destructr p.
      after destruct or HAW.
      contradict HAW.
      follows apply HnQ.
Qed.

Theorem AW_intro : forall s P Q,
  AW_seq s P Q ->
  R @s ⊨ A[P W Q].
Proof using.
  unfold AW_seq.
  tsimpl.
  intros * [H IH] *.
  destruct classic (exists i, R @(p i) ⊨ Q) as case.
  - right.
    destruct case as [i Hi].
    apply ex_first_sat_index in Hi;
      clear i;
      destruct Hi as (i & Hi & Hi_before).
    exists i.
    after split.
    after eapply AW_in_before_nQ.
    intros.
    follows tapply Hi_before.
  - left.
    positivity in case.
    intros ? [i <-].
    constructor; [ |follows tsimpl].
    gen x := (p i) to (λ x, in_path_before x (S i) p)
      by tedious;
      cbn beta;
      revert x.
    follows eapply AW_in_before_nQ.
Qed.

(* Prove AW by info of just the previous step *)
Theorem AW_intro_weak : forall s P Q,
  R @s ⊨ P || Q ->
  (forall s',
    R^* s s' ->
    (R @s' ⊨ P && !Q) ->
    forall s'',
      R s' s'' ->
      R @s'' ⊨ P || Q) ->
  R @s ⊨ A[P W Q].
Proof using.
  intros * H0 HS.
  apply AW_intro.
  split; [assumption| ].
  intros * H.
  apply HS.
  - follows apply seq__star.
  - follows apply H.
Qed.

Theorem AW_elim : forall s P Q,
  R @s ⊨ A[P W Q] ->
  forall (p: path R s) i,
    (forall x, in_path_before x i p -> R @x ⊭ Q) ->
    forall x, in_path_before x i p -> R @x ⊨ P.
Proof using.
  intros * HAW * H * Hin.
  tsimpl in HAW.
  specialize (HAW p).
  destruct or HAW.
  - specialize (HAW x).
    forward HAW by tedious.
    follows destruct HAW.
  - destruct HAW as (j & Hbefore & HQ).
    assert (i <= j).
    + contradict goal.
      transform contra (j < i) by lia.
      contradict HQ.
      follows apply H.
    + apply Hbefore.
      follows eapply in_path_before_grow.
Qed.

Theorem AW_elim_seq : forall s P Q,
  R @s ⊨ A[P W Q] ->
  forall s' (r: R#* s s'),
    (forall x, in_seq x r -> R @x ⊭ Q) ->
    R @s' ⊨ P.
Proof using.
  intros * HAW * Hin.
  overwrite HAW (AW_elim _ _ _ HAW).
  todo.
Admitted.

Theorem AW_weaken_left : forall s P P' Q,
  (forall x, R @x ⊨ P --> P') ->
  R @s ⊨ A[P W Q] ->
  R @s ⊨ A[P' W Q].
Proof using.
  intros * Hweaken HAW.
  tsimpl in *.
  intros p.
  specialize (HAW p).
  destruct or HAW; [left|right].
  - intros ? [i <-].
    specialize (HAW (p i)).
    forward HAW by tedious.
    split.
    + tapplyc Hweaken.
      tapply HAW.
    + tapply HAW.
  - destruct HAW as (i & H & H').
    exists i.
    after split.
    intros ? (j & jlt & <-).
    tapply Hweaken.
    follows apply H.
Qed.

Theorem AW_intro_right : forall s P Q,
  R @s ⊨ Q --> A[P W Q].
Proof using.
  intros *.
  tintro HnQ.
  tsimpl.
  intro p.
  right.
  follows exists 0.
Qed.

Theorem AU_is_AW_and_AF : forall s P Q,
  (R @s ⊨ A[P U Q]) = (R @s ⊨ A[P W Q] && AF Q).
Proof using.
  intros *.
  extensionality H.
  - split.
    + follows tsimpl in *.
    + tsimpl in *.
      intro p.
      follows specialize (H p).
  - destruct H as [H H'].
    tsimpl in *.
    intro p.
    specialize (H p);
      specialize (H' p).
    destruct H; [ |assumption].
    exfalso.
    destruct H' as (s' & s'_in & H').
    specialize (H s' s'_in).
    tedious.
Qed.

Theorem AG_intro_strong : forall s P,
  R @s ⊨ P ->
  (forall s' (seq: R#* s s'),
    (forall x, in_seq x seq -> R @x ⊨ P) ->
    forall s'',
      R s' s'' ->
      R @s'' ⊨ P) ->
  R @s ⊨ AG P.
Proof using.
  intros * H0 HS.
  tsimpl.
  intros p ? [i <-].
  wf_induction i lt.
  destruct i.
  - follows rewrite state_at_0.
  - specialize (HS (p i) (prefix R p i)).
    apply HS.
    + intros x Hin.
      apply inv_in_prefix in Hin as (j & ? & <-).
      follows apply wfIH.
    + follows do 2 destructr p.
Qed.

(* Lemma still_AW: forall P Q s s' (seq: R#* s s'),
  (forall x, in_seq x seq -> R @x ⊭ Q) ->
  R @s ⊨ A[P W Q] ->
  R @s' ⊨ A[P W Q]. *)

Theorem tprop_extensionality : forall P Q,
  (forall (R: relation state) (t: transition R) s, R @s ⊨ P = R @s ⊨ Q) ->
  (P = Q).
Proof using.
  intros * ext_eq.
  extensionality R' t' s.
  change (?tp R' t' s) with (R' @s ⊨ tp).
  tedious.
Qed.

Theorem tentails_eq_is_eq : forall P Q,
  (forall (R: relation state) (t: transition R) s, R @s ⊨ P = R @s ⊨ Q) =
  (P = Q).
Proof using.
  intros *.
  extensionality; split.
  - apply tprop_extensionality.
  - follows intros ->.
Qed.

(* TODO: demorgans tactic which uses an extensible hint database for rewriting? *)

Theorem AG_idempotent : forall s P,
  R @s ⊨ AG P ⇾ AG (AG P).
Proof using.
  intros *.
  tintro H.
  tsimpl.
  intros * Hin * Hin'.
  pose proof (ex_in_path_composition _ _ _ _ _ _ Hin Hin') as [? ?].
  follows etapply H.
Qed.

Theorem AG_weaken : forall s P Q,
  (forall x, R @x ⊨ P --> Q) ->
  R @s ⊨ AG P --> AG Q.
Proof using.
  intros * HWeakenAt.
  tintro HAGP.
  rewrite rew_AG_star in *.
  intros * Hstep.
  follows tapply HWeakenAt.
Qed.

(* De Morgan's Laws *)

Theorem AF_EG : forall s P,
  R @s ⊨ AF (!P) ⇾ !EG P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists Hcontra p.
  specialize (H p).
  destruct exists H s'.
  destruct H; auto.
Qed.

Theorem AF_EG' : forall s P,
  R @s ⊨ !AF P ⇾ EG (!P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  positivity in H.
  destruct exists H p.
  positivity in H.
  exists p.
  repeat intro.
  follows eapply H.
Qed.

Theorem EG_AF : forall s P,
  R @s ⊨ EG (!P) ⇾ !AF P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists H p.
  specialize (Hcontra p).
  destruct exists Hcontra s'.
  destruct Hcontra.
  follows etapply H.
Qed.

Theorem EG_AF' : forall s P,
  R @s ⊨ !EG P ⇾ AF (!P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  intros p.
  positivity in H.
  specialize (H p).
  positivity in H.
  destruct exists H s'.
  follows positivity in H.
Qed.

Theorem rew_AF_EG : forall s P,
  (R @s ⊨ AF (!P)) = (R @s ⊨ !EG P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply AF_EG.
  - tapply EG_AF'.
Qed.

Theorem rew_EG_AF : forall s P,
  (R @s ⊨ EG (!P)) = (R @s ⊨ !AF P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply EG_AF.
  - tapply AF_EG'.
Qed.

Theorem AG_EF : forall s P,
  R @s ⊨ AG (!P) ⇾ !EF P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists Hcontra p s'.
  specialize (H p s').
  now destruct H.
Qed.

Theorem AG_EF' : forall s P,
  R @s ⊨ !AG P ⇾ EF (!P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  positivity in H.
  destruct exists H p.
  positivity in H.
  destruct exists H s'.
  exists p s'.
  follows positivity in H.
Qed.

Theorem EF_AG : forall s P,
  R @s ⊨ EF (!P) ⇾ !AG P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists H p s'.
  specialize (Hcontra p s').
  destruct H as [H1 H2].
  follows etapply H2.
Qed.

Theorem EF_AG' : forall s P,
  R @s ⊨ !EF P ⇾ AG (!P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  intros p s' Hin contra.
  positivity in H.
  specialize (H p).
  positivity in H.
  follows eapply H.
Qed.

Theorem rew_AG_EF : forall s P,
  (R @s ⊨ AG (!P)) = (R @s ⊨ !EF P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply AG_EF.
  - tapply EF_AG'.
Qed.

Theorem rew_EF_AG : forall s P,
  (R @s ⊨ EF (!P)) = (R @s ⊨ !AG P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply EF_AG.
  - tapply AG_EF'.
Qed.

Theorem AX_EX : forall s P,
  R @s ⊨ AX (!P) ⇾ !EX P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists Hcontra s'.
  specialize (H s').
  destruct Hcontra.
  now apply H.
Qed.

Theorem AX_EX' : forall s P,
  R @s ⊨ !AX P ⇾ EX (!P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  positivity in H.
  destruct exists H s'.
  exists s'.
  follows positivity in H.
Qed.

Theorem EX_AX : forall s P,
  R @s ⊨ EX (!P) ⇾ !AX P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists H s'.
  specialize (Hcontra s').
  destruct H as [H1 H2].
  follows etapply H2.
Qed.

Theorem EX_AX' : forall s P,
  R @s ⊨ !EX P ⇾ AX (!P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  intros s' Hin contra.
  positivity in H.
  specialize (H s').
  follows eapply H.
Qed.

Theorem rew_AX_EX : forall s P,
  (R @s ⊨ AX (!P)) = (R @s ⊨ !EX P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply AX_EX.
  - tapply EX_AX'.
Qed.

Theorem rew_EX_AX : forall s P,
  (R @s ⊨ EX (!P)) = (R @s ⊨ !AX P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply EX_AX.
  - tapply AX_EX'.
Qed.

(* Expansion Laws *)

Theorem expand_AG : forall s P,
  R @s ⊨ AG P ⇾ P && AX (AG P).
Proof.
  intros *.
  tintro H.
  rewrite rew_AG_star in H.
  split.
  - apply H.
    reflexivity.
  - unfold_AX.
    intros * Hstep.
    rewrite rew_AG_star.
    intros * Hstar.
    apply H.
    etransitivity; [ |eassumption].
    econstructor.
    + eassumption.
    + constructor.
Qed.

Theorem unexpand_AG : forall s P,
  R @s ⊨ P && AX (AG P) ⇾ AG P.
Proof.
  intros *.
  tintro H.
  destruct H as [H1 H2].
  unfold_AX in H2.
  rewrite rew_AG_star.
  intros * Hstar.
  apply star_rt1n in Hstar.
  inv Hstar.
  - assumption.
  - specialize (H2 y H).
    rewrite rew_AG_star in H2.
    apply H2.
    now apply rt1n_star.
Qed.

Theorem rew_expand_AG : forall s P,
  (R @s ⊨ AG P) = (R @s ⊨ P && AX (AG P)).
Proof.
  intros *.
  apply textensionality.
  split.
  - tapply expand_AG.
  - tapply unexpand_AG.
Qed.

Theorem AW_next : forall s P Q,
  R @s ⊨ A[P W Q] --> !Q --> AX (A[P W Q]).
Proof using.
  intros *.
  tintros HAW HnQ.
  tsimpl; tsimpl in HAW.
  intros * Hstep *.
  specialize (HAW (path_cons R s Hstep p)).
  destruct or HAW.
  - left.
    intros ? [i <-].
    apply HAW.
    follows exists (S i).
  - right.
    destruct HAW as (i & Hbefore & HQ).
    after destruct i.
    exists i.
    after split.
    intros x (j & jlt & <-).
    apply Hbefore.
    exists (S j).
    split; [lia|tedious].
Qed.

Theorem AW_prev : forall s P Q,
  R @s ⊨ P || Q --> AX (A[P W Q]) --> A[P W Q].
Proof using.
  intros.
  tintros Hor HX.
  apply AW_intro; unfold AW_seq.
  split; [assumption| ].
  intros * H * r.
  destruct Hor as [HP|HQ].
  - unfold_AX in HX.
    destruct (destruct_seq_front _ _ _ seq) as [Hseq|Hseq].
    + inject Hseq.
      specialize (HX s'' r).
      clear - HX.
      todo.
    + destruct Hseq as (y & r' & seq' & ->).
      todo.
  - contradict HQ.
    clear - H.
    follows specialize (H s).
Admitted.

Lemma AW_expansion: forall s P Q,
  R @s ⊨ A[P W Q] ⇾ A[A[P W Q] W Q].
Proof using.
  intros.
  tintro H.
  apply AW_intro; unfold AW_seq.
  split; [left; assumption| ].
  intros * Hin_seq * Hstep.
  destruct classic (R @s'' ⊨ Q).
  { right; assumption. }
  left.
  cut (R @s' ⊨ A[P W Q]).
  - intro H1.
    apply (AW_next _ _ _) in H1.
    after tapplyc H1.
    clear - Hin_seq.
    follows specialize (Hin_seq s').
  - clear Hstep H0.
    induction seq.
    + assumption.
    + follows apply Hin_seq.
Qed.

Theorem AG_AU_AW (s: state)(P Q: tprop state):
  tentails R s
            (timpl (tdisj (AG (tconj P (tnot Q))) (AU P Q)) (AW P Q)).
Proof.
  unfold_timpl.
  intros Hdisj.
  unfold_tdisj in Hdisj.
  inversion_clear Hdisj.
  { unfold_AW.
    intros p.
    left.
    unfold_AG in H.
    specialize (H p).
    trivial. }
  { unfold_AW.
    intros p.
    right.
    unfold_AU in H.
    specialize (H p).
    trivial. }
Qed.

Close Scope tprop_scope.
End Properties.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-01-16 22:29:57 -0500 (Wed, 16 Jan 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)
Require Export RelationClasses.
Import ListNotations.
Require Import NPeano.
Require Export LibTactics.

(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.

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

Theorem beq_id_refl : forall i,
  beq_id i i = true.
Proof.
  intros. destruct i. symmetry.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  beq_id i1 i2 = true -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2. symmetry in H.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Theorem not_eq_beq_id_false : forall i1 i2,
  i1 <> i2 -> beq_id i1 i2 = false.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  assert (n <> n0).
    intros C. subst. apply H. reflexivity.
  apply beq_nat_false_iff. assumption.  Qed.

Hint Resolve beq_id_false_not_eq.
Hint Rewrite beq_id_refl.

Theorem beq_id_sym: forall i1 i2,
  beq_id i1 i2 = beq_id i2 i1.
Proof.
  intros i1 i2. destruct i1. destruct i2. apply NPeano.Nat.eqb_sym. Qed.

Theorem eq_id_dec: forall (i1 i2: id),
  {i1 = i2} + {i1 <> i2}.
Proof.
  intros.
  destruct i1, i2.
  destruct eq_nat_dec with n n0.
  left; auto.
  right; intro.
  apply n1; inversion H; auto.
Qed.

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

Definition find_where := (find_w 0).

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

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

Lemma none_ex_Some: forall {A: Type} x,
  x <> @None A ->
  exists x', x = Some x'.
Proof.
  intros. induction x.
  exists a; auto.
  exfalso; auto.
Qed.

Lemma nth_error_nil : forall {A: Type} n,
  nth_error [] n = @None A.
Proof.
  intros; induction n; auto.
Qed.

Lemma nth_error_Some' : forall {A: Type} (l: list A)  n,
  n < List.length l ->
  exists x, nth_error l n = Some x.
Proof.
  intros.
  apply <- nth_error_Some in H.
  apply none_ex_Some; auto.
Qed.

Lemma nth_error_In': forall {A:Type} (l: list A) x,
  In x l ->
  exists n, nth_error l n = Some x.
Proof.
  intros.
  induction l. simpl in H; contradiction.
  simpl in *. destruct H.
  rewrite H; simpl. exists 0; auto.
  destruct IHl as [n]; auto.
  exists (S n); auto.
Qed.

Lemma nth_error_app_app : forall A (l l': list A) n x,
  nth_error l n = Some x ->
  nth_error (l ++ l') n = Some x.
Proof.
  intros. rewrite nth_error_app1; auto.
  apply nth_error_Some. intro.
  rewrite H in H0; inversion H0.
Qed.

Lemma nth_error_same_len : forall {A B:Type} (l:list A) (l': list B) n x,
  length l = length l' ->
  nth_error l n = Some x ->
  exists y, nth_error l' n = Some y.
Proof.
  induction l, l'; intros.
  rewrite nth_error_nil in H0; inversion H0.
  simpl in H; inversion H.
  simpl in H; inversion H.
  intros; simpl in *.
  case n in *. exists b; auto.
  simpl in *.
  eapply IHl; eauto.
Qed.

Lemma nth_error_dec : forall {A: Type} l n,
  {x | nth_error l n = Some x} + {nth_error l n = @None A}.
Proof.
  intros; generalize dependent n.
  induction l.
  right; apply nth_error_nil. intro.
  case n in *. left; exists a; auto.
  simpl. apply IHl.
Defined.

Lemma nth_error_fst: forall {A: Type} {a: A} l i,
  NoDup (a::l) ->
  nth_error (a::l) i = Some a ->
  i = 0.
Proof.
  intros.
  induction i. auto.
  inversion H. subst. simpl in H0. SearchAbout nth_error.
  apply nth_error_In in H0. contradiction.
Qed.

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

Lemma findwhere_ntherror : forall xs x i,
  NoDup xs ->
  nth_error xs i = Some x ->
  find_where x xs = Some i.
Proof.
  induction xs. intros; rewrite nth_error_nil in H0; inversion H0.
  intros.
  inversion H. clear H. subst. sort.
  unfold find_where; simpl in *.
  case i in *.
    - inversion H0.  rewrite beq_id_refl. auto.
    - simpl in *. case beq_id eqn:Beq. apply beq_id_eq in Beq.
  rewrite Beq in H0. false.
  apply H3. apply nth_error_In with i; auto. apply find_w_S. eapply IHxs; auto.
Qed.

Section Ref.

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

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

Lemma find_deterministic: forall (A: Type) (R: @Referable A) d (k1: id) (x1 x2: option A),
find k1 d = x1 ->
find k1 d = x2 ->
x1 = x2.
Proof with eauto.
  intros.
  destruct x1, x2;
  destruct (@find A) in *; auto with rewrite.
  rewrite <- H; auto.
  inversion H.
  inversion H0.
  inversion H.
Qed.

Lemma findi_diff: forall (A: Type) (R: @Referable A) k a v l,
k = ref a -> a <> v -> ~findi k (a :: l) v.
Proof.
  intros.
  intro.
  inversion H1; subst.
  apply H0; auto.
  apply H5; auto.
Qed.

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

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

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

End Ref.

(** Forall for two-fold relations **)

Section Two_predicate.

Variables A B: Type.
Variable P: A -> B -> Prop.

Lemma Forall2_len: forall xs ys,
  Forall2 P xs ys -> length xs = length ys.
Proof.
  intros.
  induction H. auto.
  simpl. rewrite IHForall2; auto.
Qed.

Lemma Forall2_nth_error(l:list A)(l': list B): forall n x,
  Forall2 P l l' ->
  nth_error l n = Some x ->
  exists y, nth_error l' n = Some y.
Proof.
  intros. generalize dependent n.
  induction H.
  intros.
  rewrite nth_error_nil in H0; inversion H0.
  intros.
  case n in *.
  simpl; exists y; auto.
  simpl in *.
  apply IHForall2; auto.
Qed.

Lemma Forall2_nth_error'(l:list A)(l': list B): forall n x,
  Forall2 P l l' ->
  nth_error l' n = Some x ->
  exists y, nth_error l n = Some y.
Proof.
  intros. generalize dependent n.
  induction H.
  intros.
  rewrite nth_error_nil in H0; inversion H0.
  intros.
  case n in *.
  simpl. exists x0; auto.
  simpl in *.
  apply IHForall2; auto.
Qed.

Lemma Forall2_forall (l:list A)(l': list B): forall n x y,
  Forall2 P l l' ->
    nth_error l  n = Some x ->
    nth_error l' n = Some y -> P x y.
Proof.
  intros n x y H.
  generalize dependent n.
  induction H.
  intros.
  rewrite nth_error_nil in H. inversion H.
  intros.
  case n in *; simpl in H1, H2. inversion H1. inversion H2. rewrite <- H4, <- H5; auto.
  apply IHForall2 with n; auto.
Qed.

Lemma Forall2_exi: forall (Q: B -> B -> Prop) xs ys,
  Forall2 (fun x y => exists y', Q y' y /\ P x y') xs ys ->
  exists ys', Forall2 Q ys' ys /\ Forall2 P xs ys'.
Proof.
  intros. induction H. exists (@nil B); split; constructor.
  destruct H as [z]. destruct H. destruct IHForall2 as [zs]. destruct H2.
  exists (z :: zs). split; constructor; auto.
Qed.

Lemma Forall2_map: forall (f: A -> A) xs ys,
  Forall2 (fun x => P (f x)) xs ys ->
  Forall2 P (map f xs) ys.
Proof.
  intros. induction H. simpl; auto.
  simpl in *. constructor; auto.
Qed.

End Two_predicate.

Lemma Forall2_trans: forall (A: Type) (P: A -> A -> Prop) xs ys zs,
  Transitive P ->
  Forall2 P xs ys ->
  Forall2 P ys zs ->
  Forall2 P xs zs.
Proof.
  induction xs, ys, zs; intros; auto.
  (* Trivial Cases solved by inversion *)
  - inversion H0.
  - inversion H1.
  - inversion H1.

  - inversion H0; inversion H1. subst.
  constructor. transitivity a0; auto.
  eapply IHxs; eauto.
Qed.

(** * From Basics.v *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
match reverse goal with
| H : _ |- _ => try move x after H
end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
let H := fresh in
assert (x = v) as H by reflexivity;
clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
first [
  set (x := name); move_to_top x
| assert_eq x name; move_to_top x
| fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
match goal with
| H : _ |- _ => solve [ inversion H; subst; t ]
end
|| fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
solve by inversion 1.


(* Finitary spreads *)

From intuitionism Require Import lib set seq.

(* Spread: a subset of the entire Baire space *)
Record spread := Spr {
  σ : fseq -> bool;
  σ_nil : σ [] = true;
  σ_cons : ∀s, σ s = true <-> ∃n, σ (n :: s) = true;
}.

(* Coerce spreads to baire. *)
Section SpreadBaire.

Definition spread_member X α := ∀m, σ X ⟨α;m⟩ = true.
Definition spread_biare (X : spread) := Baire (spread_member X).
Coercion spread_biare : spread >-> baire.

Lemma unfold_inspr (X : spread) α :
  α ∈ X -> ∀m, σ X ⟨α;m⟩ = true.
Proof. auto. Qed.

Lemma intro_inspr (X : spread) α :
  (∀m, σ X ⟨α;m⟩ = true) -> α ∈ X.
Proof. auto. Qed.

End SpreadBaire.

(* Function to retract the the Baire space onto any spread. *)
Module Retract.
Section Retract.
Arguments exist {_ _}.

Variable X : spread.

(* X is decidable *)
Lemma X_dec s n : {σ X (n :: s) = true} + {~σ X (n :: s) = true}.
Proof. apply bool_dec. Qed.

(* Retract any finite sequence onto the spread. *)
Fixpoint ρ (s : fseq) : {t | σ X t = true} :=
  match s with
  | [] => exist [] (σ_nil X)
  | n :: t =>
    let ρt := proj1_sig (ρ t) in
    let ρtP := proj2_sig (ρ t) in
    match X_dec ρt n with
    | left accept => exist (n :: ρt) accept
    | right _ =>
      let ex := proj1 (σ_cons X ρt) ρtP in
      let n0 := epsilon_smallest _ (X_dec ρt) ex in
      exist (proj1_sig n0 :: ρt) (proj1 (proj2_sig n0))
    end
  end.

(* Retract function *)
Definition r α n := hd 0 (proj1_sig (ρ ⟨α;n+1⟩)).

(* r is the same as ρ *)
Lemma r_eq_ρ α n :
  ⟨r α;n⟩ = proj1_sig (ρ ⟨α;n⟩).
Proof.
induction n; simpl; auto.
destruct (ρ ⟨α;n⟩) as [ρt Hρ] eqn:Rρ; simpl in *.
destruct (X_dec ρt (α n)) eqn:RX; simpl;
rewrite IHn; apply cons_split; auto;
unfold r; rewrite add_1_r; simpl;
rewrite Rρ; simpl; rewrite RX; auto.
Qed.

(* ρ does not alter sequences in X. *)
Lemma ρ_id α n :
  α ∈ X -> proj1_sig (ρ ⟨α;n⟩) = ⟨α;n⟩.
Proof.
intros; induction n; simpl; auto.
destruct (ρ ⟨α;n⟩); simpl in *; subst.
destruct (X_dec ⟨α;n⟩ (α n)); simpl; auto.
exfalso; apply unfold_inspr with (m:=S n) in H; auto.
Qed.

(* r does not alter sequences in X. *)
Lemma r_id α :
  α ∈ X -> r α = α.
Proof.
intros; apply functional_extensionality; intros n.
unfold r; rewrite ρ_id; auto. rewrite add_1_r; simpl; auto.
Qed.

(* The image of r is in X. *)
Lemma r_image α :
  (r α) ∈ X.
Proof.
intros m; rewrite r_eq_ρ.
destruct (ρ ⟨α;m⟩) as [ρt Hρ]; auto.
Qed.

End Retract.
End Retract.

(* All spreads are inhabited. *)
Corollary spread_inhabited (X : spread) : inhabited X.
Proof. exists (Retract.r X (0^ω)). apply Retract.r_image. Qed.