(**************************************************************************)
(*           *                                                            *)
(*     _     *   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.
Require Import FunInd.

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 without_red_remove 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 without_red_not_in 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 add_prf 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 without_red_permut 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 included_remove_red 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 remove_red_included 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 without_red_remove_red 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 without_red_filter_aux 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 union_1_aux 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 union_2_aux 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 length_remove_not_common 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 subset_dec 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 cardinal_subset 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 cardinal_union_inter_12 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 subset_cardinal_not_eq_not_eq_set 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: ***
 *)


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector implmented with Recursive Pair
  author    : ZhengPu Shi
  date      : 2021.01

  remark    :
  1. the definition of vec inspired by Coquelicot.
  2. all definitions are polymorphism.

 *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Lia.
Require Export BasicConfig SetoidListExt HierarchySetoid.

Open Scope A_scope.
Open Scope vec_scope.

Generalizable Variable A B C Aeq Beq Ceq Aadd Aopp Amul Ainv.

(** ** Definition of vector *)
Section vec.

  Context {A : Type}.

  Fixpoint vec (n : nat) : Type :=
    match n with
    | O => unit
    | S n => prod A (vec n)
    end.

  (** all vec 0 are same *)
  Lemma vec_0 (v : vec 0) : v = tt.
  Proof.
    destruct v. auto.
  Qed.

  (** vec (S n) must be a prod type *)
  Lemma vec_S (n : nat) (v : vec (S n)) : {x & { v' | v = (x, v')}}.
  Proof.
    refine (match v with (x,v') => _ end). eauto.
  Qed.

End vec.

Bind Scope vec_scope with vec.

Notation "[ x ]" := (prod x (vec 0)) : vec_scope.
Notation "[ x1 ; .. ; xn ]" := (pair x1 .. (pair xn tt) .. ) : vec_scope.

(** Simplify a vector expression in hypothesis *)
Ltac vsimp :=
  repeat match goal with
    | v : vec 0 |- _ => rewrite (vec_0 v)
    | v : vec (S ?n) |- _ => destruct v
    | H : ?P (?a1,?v1) (?a2,?v2) |- _ => try destruct H
    end.

(** ** Equality of vec *)
Section veq.
  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.

  Fixpoint veq {n} : vec n -> vec n -> Prop :=
    match n with
    | O => fun _ _ => True
    | S n' => fun (v1 v2 : vec (S n')) =>
               let (a1,v1') := v1 in
               let (a2,v2') := v2 in
               (a1 == a2) /\ veq v1' v2'
    end.
  Infix "==" := veq : vec_scope.

  Lemma veq_refl : forall n, Reflexive (veq (n:=n)).
  Proof.
    unfold Reflexive. induction n; intros; simpl; auto.
    destruct x. split; auto. easy.
  Qed.

  Lemma veq_sym : forall n, Symmetric (veq (n:=n)).
  Proof.
    unfold Symmetric. induction n; intros; simpl; auto.
    destruct x,y. inv H. split; auto. easy.
  Qed.

  Lemma veq_trans : forall n, Transitive (veq (n:=n)).
  Proof.
    unfold Transitive. induction n; intros; simpl; auto.
    destruct x,y,z. inv H. inv H0. split; auto.
    rewrite H1; auto. apply IHn with v0; auto.
  Qed.

  Lemma veq_equiv : forall n : nat, Equivalence (veq (n:=n)).
  Proof.
    constructor. apply veq_refl. apply veq_sym. apply veq_trans.
  Qed.

  Global Existing Instance veq_equiv.

  (** veq is decidable *)
  Lemma veq_dec : forall n (Dec_Aeq : Decidable Aeq), Decidable (veq (n:=n)).
  Proof.
    induction n; constructor; intros.
    - rewrite (vec_0 a), (vec_0 b). left. easy.
    - destruct a,b.
      destruct (decidable a a0), (decidable v v0).
      + left. split; auto.
      + right. intro. inv H. easy.
      + right. intro. inv H. easy.
      + right. intro. inv H. easy.
  Qed.

  (** Bool equality of vec *)
  Fixpoint veqb {n : nat} (Aeqb : A -> A -> bool) : vec n -> vec n -> bool :=
    match n with
    | O => fun (v1 v2 : vec 0) => true
    | S n' => fun (v1 v2 : vec (S n')) =>
               andb (Aeqb (fst v1) (fst v2)) (veqb Aeqb (snd v1) (snd v2))
    end.

End veq.

(** ** pair, fst, snd *)
Section pair_fst_snd.
  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : A_scope.

  (** pair is a proper morphism *)
  Lemma pair_aeq_mor : forall n,
      Proper (Aeq ==> veq (Aeq:=Aeq)(n:=n) ==> veq (Aeq:=Aeq)(n:=S n)) (pair).
  Proof.
    unfold Proper, respectful. induction n; intros; vsimp; simpl; auto.
  Qed.

  Global Existing Instance pair_aeq_mor.

  (** fst is a proper morphism *)
  Lemma fst_aeq_mor : forall n,
      Proper (veq (Aeq:=Aeq)(n:=S n) ==> Aeq) (fst).
  Proof.
    unfold Proper, respectful. induction n; intros; vsimp; simpl; auto.
  Qed.

  Global Existing Instance fst_aeq_mor.

  (** snd is a proper morphism *)
  Lemma snd_aeq_mor : forall n,
      Proper (veq (Aeq:=Aeq)(n:=S n) ==> veq (Aeq:=Aeq)(n:=n)) (snd).
  Proof.
    unfold Proper, respectful. induction n; intros; vsimp; simpl; auto.
  Qed.

  Global Existing Instance snd_aeq_mor.

End pair_fst_snd.

(** ** Construct a vector with same element *)
Section vconst.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : A_scope.

  Fixpoint vconst (n : nat) (val : A) : vec n :=
    match n with
    | O => tt
    | S n' => (val, vconst n' val)
    end.

  Lemma vconst_aeq_mor : forall n, Proper (Aeq ==> veq (Aeq:=Aeq)(n:=n)) (vconst n).
  Proof.
    unfold Proper, respectful. induction n; intros; simpl; auto.
  Qed.

  Global Existing Instance vconst_aeq_mor.

End vconst.

Arguments vconst {A}.

(** ** vec0, its elements is 0 *)
Section vec0.

  Context `{Equiv_Aeq : Equivalence A Aeq} (A0 : A).
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : A_scope.

  Definition vec0 (n : nat) := vconst n A0.

  Lemma vec0_S : forall n, vec0 (S n) == (A0, vec0 n).
  Proof.
    intros; simpl. easy.
  Qed.

  Lemma vec0_eq_vconst0 : forall n, vec0 n = vconst n A0.
  Proof. auto. Qed.

End vec0.

(** ** head and tail of a vector *)
Section vhd_vtl.

  Context `{Equiv_Aeq : Equivalence A Aeq} (A0 : A).
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : A_scope.

  Definition vhd {n} : vec n -> A :=
    match n with
    | O => fun (_ : vec O) => A0
    | S n' => fun (v : vec (S n')) => fst v
    end.

  Definition vtl {n} (v : @vec A (S n)) : vec n := snd v.

End vhd_vtl.

(** ** Get last element *)
Section vlast.

  Context `{Equiv_Aeq : Equivalence A Aeq} (A0 : A).
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : A_scope.

  (* why fail? *)
  Fail Fixpoint vlast {n : nat} : vec n -> A :=
    match n with
    | O => fun (_ : vec O) => A0
    | 1 => fun (v : vec 1) => fst v
    | S n' => fun (v : vec (S n')) => @vlast n' (snd v)
    end.

  Fixpoint vlast {n} : vec (S n) -> A :=
    match n with
    | O => fun (v : vec 1) => fst v
    | S n' => fun (v : vec (S (S n'))) => vlast (snd v)
    end.

End vlast.

(** Construct a vector with a function *)
Section vmake.

  Context `{Equiv_Aeq : Equivalence A Aeq} (A0 : A).
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : A_scope.

  (* it is wrong direction, we need (f 0, f 1 ..), but got (f n, f (n-1) ..) *)
  Fixpoint vmake_old (n : nat) (f : nat  -> A) : vec n :=
    match n with
    | O => tt
    | S n' => (f n', vmake_old n' f)
    end.

  (** Generate vector with an offset, that is : f i, f (i+1), ... *)
  Fixpoint vmakeAux (n : nat) (i : nat) (f : nat  -> A) : vec n :=
    match n with
    | O => tt
    | S n' => (f i, vmakeAux n' (S i) f)
    end.

  (** vmakeAux is proper morphism *)
  Lemma vmakeAux_aeq_mor : forall n : nat,
      Proper (eq ==> (eq ==> Aeq) ==> veq (Aeq:=Aeq)(n:=n)) (vmakeAux n).
  Proof.
    unfold Proper, respectful.
    induction n; intros; simpl; auto.
  Qed.

  Global Existing Instance vmakeAux_aeq_mor.

  Lemma vmakeAux_S : forall (n : nat) (i : nat) (f : nat  -> A),
      vmakeAux n (S i) f == vmakeAux n i (fun j => f (S j)).
  Proof.
    induction n; intros; simpl; auto. split; auto. easy.
  Qed.

  Lemma vmakeAux_const_eq_vconst : forall n i a,
      (vmakeAux n i (fun _ : nat => a) == vconst n a).
  Proof.
    induction n; intros; simpl; easy.
  Qed.

  Definition vmake (n : nat) (f : nat  -> A) : vec n := vmakeAux n 0 f.

  Lemma vmake_0 : forall (f : nat  -> A), vmake 0 f = tt.
  Proof.
    auto.
  Qed.

  Lemma vmake_S : forall n (f : nat  -> A), vmake (S n) f == (f 0, vmake n (fun i => f (S i))).
  Proof.
    intros. simpl. split; try easy. apply vmakeAux_S.
  Qed.

  Lemma vmake_const_eq_vconst : forall n a, (vmake n (fun _ : nat => a) == vconst n a).
  Proof.
    intros. apply vmakeAux_const_eq_vconst.
  Qed.

End vmake.

(** ** Append two vectors *)
Section vapp.

  Context {A : Type}.

  Fixpoint vapp {n1 n2} : @vec A n1 -> vec n2 -> vec (n1 + n2) :=
    match n1 with
    | 0 => fun (v1 : vec 0) (v2 : vec n2) => v2
    | S n1' => fun (v1 : vec (S n1')) (v2 : vec n2) =>
                (fst v1, vapp (snd v1) v2)
    end.

End vapp.

(** Reverse a vector *)
Section vrev.

  Variable A : Type.

  Fail Fixpoint vrev {n : nat} : @vec A n -> @vec A n :=
    match n with
    | O => fun _ => let v : @vec A 0 := tt in v
    | S n' => fun (v : @vec A (S n')) => let (x, v') := v in
                                      @vapp A n' 1 (vrev v') [x]
    end.

End vrev.

(** Get n-th element of a vector *)
Section vnth.

  Context `{Equiv_Aeq : Equivalence A Aeq} {A0 : A}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  Fixpoint vnth {n} (i : nat) : (vec n) -> A :=
    match n with
    | O => fun (_ : vec O) => A0
    | S n' => fun (v : vec (S n')) =>
               match i with
               | O => (fst v)
               | S i' => vnth i' (snd v)
               end
    end.

  (** vnth is a proper morphism *)
  Lemma vnth_aeq_mor : forall n, Proper (eq ==> veq (Aeq:=Aeq) (n:=n) ==> Aeq) vnth.
  Proof.
    unfold Proper, respectful.
    induction n; intros; vsimp; try easy.
    simpl. destruct x,y; auto; try easy.
  Qed.

  Global Existing Instance vnth_aeq_mor.

  Lemma vnth_0 {n} (v : vec (S n)) : (vnth 0 v == fst v)%A.
  Proof.
    destruct v. simpl. easy.
  Qed.

  Lemma vnth_S {n} i (v : vec (S n)) :
    (* let (_, v') := v in (vnth (S i) v == vnth i v')%A. *)
    (vnth (S i) v == vnth i (snd v))%A.
  Proof.
    simpl. easy.
  Qed.

  (** Every element pair of two vectors are same iff the two vectors same *)
  Lemma veq_iff_vnth : forall {n} (v1 v2 : vec n),
      v1 == v2 <-> (forall i, i < n -> (vnth i v1 == vnth i v2)%A).
  Proof.
    induction n; intros; vsimp; split; intros; try easy; vsimp.
    - destruct i; simpl; auto. apply IHn; auto. lia.
    - split.
      + apply (H 0). lia.
      + apply IHn. intros. apply (H (S i)). lia.
  Qed.

  Lemma vnth_const : forall n i (a : A), i < n -> (vnth i (vconst n a) == a)%A.
  Proof.
    induction n; intros; simpl. lia. destruct i. easy. apply IHn. lia.
  Qed.

  Lemma vnth_vec0 : forall n i, (vnth i (vec0 A0 n) == A0)%A.
  Proof.
    induction n; intros; simpl. easy. destruct i; auto. easy.
  Qed.

  Lemma vnth_vmake_valid : forall {n} f i, i < n -> (vnth i (vmake n f) == f i)%A.
  Proof.
    induction n; intros; simpl. lia. destruct i. easy.
    rewrite vmakeAux_S. unfold vmake in *. rewrite IHn. easy. lia.
  Qed.

  Lemma vnth_vmake_invalid : forall {n} f i, i >= n -> (vnth i (vmake n f) == A0)%A.
  Proof.
    induction n; intros; simpl. easy. destruct i. easy. unfold vmake in *.
    rewrite vmakeAux_S. rewrite IHn. easy. lia.
  Qed.

  Lemma vnth_vmakeAux_valid : forall {n} f i j,
      i+j < n -> (vnth i (vmakeAux n j f) == f (i + j))%A.
  Proof.
    induction n; intros; simpl. lia. destruct i. easy.
    rewrite vmakeAux_S. rewrite IHn. easy. lia.
  Qed.

  Lemma vnth_vmakeAux_invalid : forall {n} f i j,
      i >= n -> (vnth i (vmakeAux n j f) == A0)%A.
  Proof.
    induction n; intros; simpl. easy. destruct i. easy.
    rewrite vmakeAux_S. rewrite IHn. easy. lia.
  Qed.

End vnth.

(** ** Get top or remain element of a vector *)
Section vfirstn_vskipn.
  Context `{Equiv_Aeq : Equivalence A Aeq} {A0 : A}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  (** Get top k elements of a vector *)
  Fixpoint vfirstn {n} (k : nat) : (vec n) -> (vec k) :=
    match n,k with
    | O, O => fun (v : vec O) => tt
    | O, S k' => fun (v : vec O) => (A0, vfirstn k' v)
    | S n', O => fun (v : vec (S n')) => tt
    | S n', S k' => fun (v : vec (S n')) => (fst v, vfirstn k' (snd v))
    end.

  (** Get remain (n-k) elements of a vector *)
  Fixpoint vskipn {n} (k : nat) : @vec A n -> vec (n-k) :=
    match n,k with
    | O, O => fun (v : vec 0) => let v1 : vec (0-0) := tt in v1
    | O, S k' => fun (v : vec O) => let v1 : vec (0 - (S k')) := tt in v1
    | S n', O => fun (v : vec (S n')) => let v1 : vec (S n' - 0) := v in v1
    | S n', S k' => fun (v : vec (S n')) => let v1 : vec (S n' - S k') :=
                                              vskipn k' (snd v) in v1
    end.

End vfirstn_vskipn.

(** ** Maping of a vector *)
Section vmap.
  (* Context `{Equiv_Aeq : Equivalence A Aeq} {A0 : A}. *)
  (* Context `{Equiv_Beq : Equivalence B Beq} {B0 : A}. *)
  Context `{Aeq : relation A} `{Beq : relation B}.
  (* Infix "==" := Aeq : A_scope. *)
  (* Infix "==" := (veq (Aeq:=Aeq)) : vec_scope. *)

  (** Maping of a vector *)
  Fixpoint vmap {n} (f : A -> B) : @vec A n -> @vec B n :=
    match n with
    | O => fun (v : vec 0) => tt
    | S n' => fun (v : vec (S n')) => (f (fst v), vmap f (snd v))
    end.

  (** vmap is proper morphism *)
  Lemma vmap_aeq_mor : forall n : nat,
      Proper ((Aeq ==> Beq) ==> veq (Aeq:=Aeq) ==> veq (Aeq:=Beq)) (vmap (n:=n)).
  Proof.
    unfold Proper, respectful.
    induction n; intros; simpl; auto; vsimp.
    split; auto.
  Qed.

  Global Existing Instance vmap_aeq_mor.

End vmap.

(** ** Maping of two vectors *)
Section vmap2.
  Context `{Aeq : relation A} `{Beq : relation B}.
  Context `{Equiv_Ceq : Equivalence C Ceq}.
  Infix "==" := (veq (Aeq:=Ceq)) : vec_scope.

  (** Maping of two vectors *)
  Fixpoint vmap2 {n} (f : A -> B -> C) : @vec A n -> @vec B n -> @vec C n :=
    match n with
    | O => fun (v1 : vec 0) (v2 : vec 0) => tt
    | S n' => fun (v1 : vec (S n')) (v2 : vec (S n')) =>
                (f (fst v1) (fst v2), vmap2 f (snd v1) (snd v2))
    end.

  (** vmap2 is proper morphism *)
  Lemma vmap2_aeq_mor : forall n,
      Proper ((Aeq ==> Beq ==> Ceq) ==>
                veq (Aeq:=Aeq) ==>
                veq (Aeq:=Beq) ==>
                veq (Aeq:=Ceq)) (vmap2 (n:=n)).
  Proof.
    unfold Proper, respectful.
    induction n; intros; simpl; auto; vsimp; simpl.
    split; auto.
  Qed.

  Global Existing Instance vmap2_aeq_mor.

  Lemma vmap2_S : forall {n} f t1 t2 (v1 v2 : vec n),
      vmap2 f ((t1, v1):vec (S n)) (t2, v2) == (f t1 t2, vmap2 f v1 v2).
  Proof.
    intros. simpl. easy.
  Qed.

End vmap2.

(** Properties of vmap2 with same type *)
Section vmap2_sametype.
  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  Lemma vmap2_comm {n} f (fComm : Commutative f Aeq)
      (v1 v2 : vec n): vmap2 f v1 v2 == vmap2 f v2 v1.
  Proof.
    induction n; intros; destruct v1,v2; simpl; try easy. split; auto.
    apply commutative.
  Qed.

  Lemma vmap2_assoc {n} f (fAssoc : Associative f Aeq)
    (v1 v2 v3 : vec n) :
    vmap2 f (vmap2 f v1 v2) v3 == vmap2 f v1 (vmap2 f v2 v3).
  Proof.
    induction n; intros; destruct v1,v2; simpl; try easy. split; auto.
    apply associative.
  Qed.

End vmap2_sametype.

(** ** Fold a vector to an element *)
Section vfold.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  (** Fold a vector to an element from left to right *)
  Fixpoint vfoldl {n} (Aadd : A -> A -> A) (A0 : A) : (vec n) -> A :=
    match n with
    | O => fun (v : vec 0) => A0
    | S n' => fun (v : vec (S n')) => Aadd (fst v) (vfoldl Aadd A0 (snd v))
    end.

  (** Fold a vector to an element from right to left *)
  Fixpoint vfoldr {n} (Aadd : A -> A -> A) (A0 : A) : (vec n) -> A :=
    match n with
    | O => fun (v : vec 0) => A0
    | S n' => fun (v : vec (S n')) => Aadd (vfoldr Aadd A0 (snd v)) (fst v)
    end.

  (** vfoldl is proper morphism *)
  Lemma vfoldl_aeq_mor : forall (n : nat) (f : A -> A -> A)
                           {fProper : Proper (Aeq ==> Aeq ==> Aeq) f},
      Proper (Aeq ==> veq (Aeq:=Aeq) (n:=n) ==> Aeq) (vfoldl f).
  Proof.
    unfold Proper, respectful.
    induction n; intros; vsimp; simpl. easy. f_equiv; auto.
  Qed.

  Global Existing Instance vfoldl_aeq_mor.

  (** ToDo: A problem *)
  Section a_problem.

    Variable (Aadd Amul : A -> A -> A) (A0 A1 : A).
    Variable (AaddProper : Proper (Aeq ==> Aeq ==> Aeq) Aadd).

    Goal forall n (v1 v2 : vec n),
        v1 == v2 ->
        (vfoldl Aadd A0 v1 == vfoldl Aadd A0 v2)%A.
    Proof.
      intros.
      (** why f_equiv here cannot reduce to a "==" relation, but a "=" relation ? *)
      (* f_equiv. *)
      rewrite H. easy.
    Abort.

  End a_problem.

End vfold.

(** ** Concatenation a nested vector to a plain vector *)
Section vvflat.
  Context {A : Type}.

  Fixpoint vvflat {r c} : (@vec (@vec A c) r) -> @vec A (r * c) :=
    match r with
    | O => fun (m : @vec (vec c) 0) => tt
    | S r' => fun (m : @vec (vec c) (S r')) =>
                vapp (fst m) (vvflat (snd m))
    end.

End vvflat.

(** ** Convert between vector and list *)
Section v2l_l2v.
  Context `{Equiv_Aeq : Equivalence A Aeq} {A0 : A}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  Fixpoint v2l {n} : @vec A n -> list A :=
    match n with
    | 0 => fun (v : @vec A 0) => nil
    | S n' => fun (v : @vec A (S n')) => cons (fst v) (v2l (snd v))
    end.

  Lemma v2l_length : forall n (v : @vec A n), length (v2l v) = n.
  Proof.
    induction n; intros; destruct v; simpl; auto.
  Qed.

  Fixpoint l2v (l : list A) (n : nat) {struct n} : vec n :=
    match n as n0 return (vec n0) with
    | 0 => tt
    | S n' => (hd A0 l, l2v (tl l) n')
    end.

  Lemma v2l_l2v_id : forall (n : nat) (l : list A),
      length l = n -> (v2l (l2v l n) == l)%list.
  Proof.
    induction n; intros; simpl.
    - apply length_zero_iff_nil in H. subst. easy.
    - destruct l. easy. apply cons_aeq_mor; auto. simpl. easy.
  Qed.

  Lemma l2v_v2l_id : forall (n : nat) (v : vec n), l2v (v2l v) n == v.
  Proof.
    induction n; destruct v; simpl; auto. split; auto. easy.
  Qed.

End v2l_l2v.

(* Check ([1;2;3] : vec 3). *)
(* Compute v2l ([1;2;3] : vec 3). *)
(* Compute l2v (cons 1 (cons 2 nil)) 2. *)

(** ** Vector algebric *)
Section vec_alg.

  (* Variable A : Type. *)
  (* Variable A0 : A. *)
  (* Variable fadd : A -> A -> A. *)
  (* Variable fadd_comm : forall a b, fadd a b = fadd b a. *)
  (* Variable fadd_assoc : forall a b c, fadd (fadd a b) c = fadd a (fadd b c). *)
  (* Variable fadd_0_l : forall t, fadd A0 t = t. *)
  (* Variable fmul : A -> A -> A. *)
  (* Variable fmul_add_distr_l : forall a b1 b2, *)
  (*     fmul a (fadd b1 b2) = fadd (fmul a b1) (fmul a b2). *)
  (* Variable fmul_add_distr_r : forall a1 a2 b, *)
  (*     fmul (fadd a1 a2) b = fadd (fmul a1 b) (fmul a2 b). *)

  Context `{AG : AGroup}.
  Infix "+" := Aadd : A_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Infix "-" := (fun a b => a + (-b)) : A_scope.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  (** *** vector addition *)

  Definition vadd {n} (v1 v2 : vec n) : vec n := vmap2 Aadd v1 v2.
  Infix "+" := vadd : vec_scope.

  (** vadd is proper morphism *)
  Lemma vadd_aeq_mor : forall n,
      Proper (veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq)) (vadd (n:=n)).
  Proof.
    unfold Proper, respectful.
    induction n; intros; vsimp; simpl; auto. split.
    - apply monoidAaddProper; auto.
    - apply IHn; auto.
  Qed.

  Global Existing Instance vadd_aeq_mor.

  (** v1 + v2 = v2 + v1 *)
  Lemma vadd_comm {n} (v1 v2 : vec n): v1 + v2 == v2 + v1.
  Proof.
    apply vmap2_comm. apply amonoidComm.
  Qed.

  (** (v1 + v2) + v3 = v1 + (v2 + v3) *)
  Lemma vadd_assoc {n} (v1 v2 v3 : vec n): (v1 + v2) + v3 == v1 + (v2 + v3).
  Proof.
    apply vmap2_assoc. apply monoidAssoc.
  Qed.

  (** (t1,v1) + (t2,v2) = (t1 + t2, v1 + v2) *)
  Lemma vadd_S : forall {n} t1 t2 (v1 v2 : vec n),
      ((t1, v1) : vec (S n)) + (t2, v2) == (Aadd t1 t2, v1 + v2).
  Proof.
    intros; simpl. easy.
  Qed.

  (** vec0 + v = v *)
  Lemma vadd_0_l : forall {n} (v : vec n), (vec0 A0 n) + v == v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [group_simpl|apply IHn].
  Qed.

  (** v + vec0 = v *)
  Lemma vadd_0_r : forall {n} (v : vec n), v + (vec0 A0 n) == v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [group_simpl|apply IHn].
  Qed.

  (** *** vector opposition *)

  Definition vopp {n} (v : vec n) : vec n := vmap Aopp v.
  Notation "- v" := (vopp v) : vec_scope.

  (** vopp is proper morphism *)
  Lemma vopp_aeq_mor : forall n,
      Proper (veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq)) (vopp (n:=n)).
  Proof.
    unfold Proper, respectful.
    induction n; intros; vsimp; simpl; auto. split.
    - apply groupAoppProper; auto.
    - apply IHn; auto.
  Qed.

  Global Existing Instance vopp_aeq_mor.

  (** - (a,v) = (-a, -v) *)
  Lemma vopp_S : forall {n} a (v : vec n), - ((a, v) : vec (S n)) == ((-a)%A, - v).
  Proof.
    intros. easy.
  Qed.

  (** - (- v) = v *)
  Lemma vopp_vopp : forall {n} (v : vec n), - (- v) == v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [apply group_inv_inv| apply IHn].
  Qed.

  (** (-v) + v = vec0 *)
  Lemma vadd_vopp_l : forall {n} (v : vec n), (-v) + v == vec0 A0 n.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [group_simpl|apply IHn].
  Qed.

  (** v + (-v) = vec0 *)
  Lemma vadd_vopp_r : forall {n} (v : vec n), v + (-v) == vec0 A0 n.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [group_simpl|apply IHn].
  Qed.

  (** *** vector subtraction *)

  Definition vsub {n} (v1 v2 : vec n) : vec n := v1 + (- v2).
  Infix "-" := vsub : vec_scope.

  (** vsub is proper morphism *)
  Lemma vsub_aeq_mor : forall n,
      Proper (veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq)) (vsub (n:=n)).
  Proof.
    unfold Proper, respectful.
    induction n; intros; vsimp; simpl; auto. split.
    - apply monoidAaddProper; auto. apply groupAoppProper; auto.
    - apply IHn; auto.
  Qed.

  Global Existing Instance vsub_aeq_mor.

  (** v1 - v2 = - (v2 - v1) *)
  Lemma vsub_comm : forall {n} (v1 v2 : vec n), v1 - v2 == - (v2 - v1).
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ | apply IHn].
    rewrite group_inv_distr. rewrite group_inv_inv. easy.
  Qed.

  (** (v1 - v2) - v3 = v1 - (v2 + v3) *)
  Lemma vsub_assoc {n} (v1 v2 v3 : vec n): (v1 - v2) - v3 == v1 - (v2 + v3).
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [| apply IHn].
    group_simpl. f_equiv. rewrite group_inv_distr. apply commutative.
  Qed.

  (** (a1,v1) - (a2,v2) = (a1-a2, v1-v2) *)
  Lemma vsub_S : forall {n} a1 a2 (v1 v2 : vec n),
      ((a1,v1):vec (S n)) - (a2,v2) == ((a1-a2)%A, v1-v2).
  Proof.
    intros. easy.
  Qed.

  (** vec0 - v = - v *)
  Lemma vsub_0_l : forall {n} (v : vec n), (vec0 A0 n) - v == - v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [group_simpl|apply IHn].
  Qed.

  (** v - vec0 = v *)
  Lemma vsub_0_r : forall {n} (v : vec n), v - (vec0 A0 n) == v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [|apply IHn].
    rewrite group_opp_zero_eq_zero. group_simpl.
  Qed.

  (** v - v = vec0 *)
  Lemma vsub_self : forall {n} (v : vec n), v - v == vec0 A0 n.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [group_simpl| apply IHn].
  Qed.

  (** *** Vector Group *)

  (** vec operation has a group structure *)
  Lemma vec_AG : forall n, @AGroup (vec (A:=A) n) vadd (vec0 A0 n) vopp (veq (Aeq:=Aeq)).
  Proof.
    intros. repeat constructor;
      try apply veq_equiv;
      auto using vadd_aeq_mor, vopp_aeq_mor, vadd_assoc, vadd_comm;
      auto using vadd_0_l, vadd_0_r, vopp_aeq_mor, vadd_vopp_l, vadd_vopp_r.
  Qed.

  (** *** Below, need Ring structure *)

  Context `{R : Ring A Aadd A0 Aopp Amul A1 Aeq}.
  Infix "*" := Amul : A_scope.
  Add Ring ring_inst : make_ring_theory.

  (** *** vector scalar multiplication *)

  Definition vcmul {n} a v : vec n := vmap (fun x => a * x) v.
  Infix "c*" := vcmul : vec_scope.

  Definition vmulc {n} v a : vec n := vmap (fun x => x * a) v.
  Infix "*c" := vmulc : vec_scope.

  (** vcmul is proper morphism *)
  Lemma vcmul_aeq_mor : forall n,
      Proper (Aeq ==> veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq)) (vcmul (n:=n)).
  Proof.
    unfold Proper, respectful.
    induction n; intros; vsimp; simpl; auto. split; auto.
    - rewrite H,H0. easy.
    - apply IHn; auto.
  Qed.

  Global Existing Instance vcmul_aeq_mor.

  (** a c* v = v *c a *)
  Lemma vmulc_eq_vcmul : forall {n} a (v : vec n), v *c a == a c* v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ring | apply IHn].
  Qed.

  (** a c* (b,v) = (a*b, a c* v) *)
  Lemma vcmul_S : forall {n} a b (v : vec n), a c* ((b,v):vec (S n)) == (a*b, a c* v).
  Proof.
    intros; simpl. easy.
  Qed.

  (** (b,v) *c a = (b*a, v *c a) *)
  Lemma vmulc_S : forall {n} a b (v : vec n), ((b,v):vec (S n)) *c a == (b*a, v *c a).
  Proof.
    intros; simpl. easy.
  Qed.

  (** 0 c* v = vec0 *)
  Lemma vcmul_0_l : forall {n} (v : vec n), A0 c* v == vec0 A0 n.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ring | apply IHn].
  Qed.

  (** a c* vec0 = vec0 *)
  Lemma vcmul_0_r : forall {n} a, a c* (vec0 A0 n) == vec0 A0 n.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ring | apply IHn].
  Qed.

  (** 1 c* v = v *)
  Lemma vcmul_1_l : forall {n} (v : vec n), A1 c* v == v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ring | apply IHn].
  Qed.

  (** a c* (v1 + v2) = a c* v1 + a c* v2 *)
  Lemma vcmul_add_distr_l : forall {n} a (v1 v2 : vec n),
      a c* (v1 + v2) == a c* v1 + a c* v2.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ring | apply IHn].
  Qed.

  (** (a + b) c* v = a c* v + b c* v *)
  Lemma vcmul_add_distr_r : forall {n} a b (v : vec n),
      (a + b)%A c* v == a c* v + b c* v.
  Proof.
    induction n; intros; vsimp; simpl; auto. split; [ring | apply IHn].
  Qed.

  (* Variable fmul : A -> A -> A. *)
  (* Variable fmul_comm : forall a b, fmul a b = fmul b a. *)
  (* Variable fmul_assoc : forall a b c, fmul (fmul a b) c = fmul a (fmul b c). *)

  (** a c* (b c* v) = (a * b) c* v *)
  Lemma vcmul_assoc : forall {n:nat} a b (v : vec n), a c* (b c* v) == (a * b) c* v.
  Proof.
    induction n; intros; simpl; auto. split; try apply IHn. ring.
  Qed.

  (** a c* (b c* v) = b c* (a c* v) *)
  Lemma vcmul_perm : forall {n} a b (v : vec n), a c* (b c* v) == b c* (a c* v).
  Proof.
    induction n; intros; simpl; auto. split; try apply IHn. ring.
  Qed.

  (** *** Vector Dot Product *)

  Definition vdot {n} (v1 v2 : vec n) := vfoldl Aadd A0 (vmap2 Amul v1 v2).
  Infix "\o" := vdot : vec_scope.

  (** vdot is proper morphism *)
  Lemma vdot_aeq_mor : forall n,
      Proper (veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq) ==> Aeq) (vdot (n:=n)).
  Proof.
    unfold Proper, respectful.
    intros. apply vfoldl_aeq_mor; try easy.
    apply monoidAaddProper.
    rewrite H,H0. easy.
  Qed.

  Global Existing Instance vdot_aeq_mor.

  (** (a1,v1) \o (a2,v2) = (a1*a2) + (v1 \o v2) *)
  Lemma vdot_S : forall {n} (a1 a2 : A) (v1 v2 : vec n),
       (((a1,v1):vec (S n)) \o (a2,v2) == (a1*a2) + (v1 \o v2))%A.
  Proof.
    unfold vdot. intros. simpl. easy.
  Qed.

  (** v1 \o v2 = v2 \o v1 *)
  Lemma vdot_comm {n} (v1 v2 : vec n) : (v1 \o v2 == v2 \o v1)%A.
  Proof.
    unfold vdot. apply vfoldl_aeq_mor.
    apply groupAaddProper. easy.  apply vmap2_comm. apply amonoidComm.
  Qed.

  (* (** vec0 \o vec0 = 0 *) *)
  (* Lemma vdot_vec0 (v : vec 0) : (v \o v == A0)%A. *)
  (* Proof. unfold vdot. simpl. easy. Qed. *)

  (** vec0 \o v = 0 *)
  Lemma vdot_0_l : forall {n} (v : vec n), ((vec0 A0 n) \o v == A0)%A.
  Proof.
    unfold vdot. induction n; intros; simpl; auto. easy. rewrite IHn. ring.
  Qed.

  (** v \o vec0 = 0 *)
  Lemma vdot_0_r : forall {n} (v : vec n), (v \o (vec0 A0 n) == A0)%A.
  Proof.
    unfold vdot. induction n; intros; simpl; auto. easy. rewrite IHn. ring.
  Qed.

  (** (a c* v1) \o v2 = a * (v1 \o v2) *)
  Lemma vdot_vcmul_l : forall {n} a (v1 v2 : vec n), ((a c* v1) \o v2 == a * (v1 \o v2))%A.
  Proof.
    unfold vdot,vcmul. induction n; intros; simpl; auto. ring. rewrite IHn. ring.
  Qed.

  (** v1 \o (a c* v2) = a * (v1 \o v2) *)
  Lemma vdot_vcmul_r : forall {n} a (v1 v2 : vec n), (v1 \o (a c* v2) == a * (v1 \o v2))%A.
  Proof.
    unfold vdot,vcmul. induction n; intros; simpl; auto. ring. rewrite IHn. ring.
  Qed.

  (** (v1 *c a) \o v2 = a * (v1 \o v2) *)
  Lemma vdot_vmulc_l : forall {n} a (v1 v2 : vec n), ((v1 *c a) \o v2 == a * (v1 \o v2))%A.
  Proof.
    unfold vdot,vmulc. induction n; intros; simpl; auto. ring. rewrite IHn. ring.
  Qed.

  (** v1 \o (v2 *c a) = a * (v1 \o v2) *)
  Lemma vdot_vmulc_r : forall {n} a (v1 v2 : vec n), (v1 \o (v2 *c a) == a * (v1 \o v2))%A.
  Proof.
    unfold vdot,vmulc. induction n; intros; simpl; auto. ring. rewrite IHn. ring.
  Qed.

  (** v1 \o (v2 + v3) = (v1 \o v2) + (v1 \o v3) *)
  Lemma vdot_vadd_l : forall {n} (v1 v2 v3 : vec n),
      (v1 \o (v2 + v3) == (v1 \o v2) + (v1 \o v3))%A.
  Proof.
    unfold vdot,vadd. induction n; intros; simpl; auto. ring. rewrite IHn. ring.
  Qed.

  (** (v1 + v2) \o v3 = (v1 \o v3) + (v2 \o v3) *)
  Lemma vdot_vadd_r : forall {n} (v1 v2 v3 : vec n),
      ((v1 + v2) \o v3 == (v1 \o v3) + (v2 \o v3))%A.
  Proof.
    unfold vdot,vadd. induction n; intros; simpl; auto. ring. rewrite IHn. ring.
  Qed.

  (** *** Vector multiplication *)

  (** vector multiplication: vec n1 -> vec n2 -> vec n2.
      Def: (a1 a2) * (b1 b2 b3) = (a1*b1+a2*b1  a1*b2+a2*b2  a1*b3+a2*b3
      (1) = (a1+a2+..) c* (b1 b2 b3)
      (2) = a1 c* (b1 b2 b3) + a2 c* (b1 b2 b3) + ...
   *)

  (* Context `{Equiv_Aeq : Equivalence A Aeq}. *)
  (* Context {Aadd Amul : A -> A -> A} {A0 : A}. *)

  (** Vector multiplication implemented with method (1) *)
  Definition vmul {n1 n2} (v1 : vec n1) (v2 : vec n2) : vec n2 :=
    vcmul (vfoldl Aadd A0 v1) v2.

  (** Vector multiplication implemented with method (2) *)
  Definition vmul' {n1 n2} (v1 : vec n1) (v2 : vec n2) : vec n2 :=
    let v' : vec n1 := vmap (fun (a:A) => (vcmul a v2)) v1 in
    vfoldl vadd (vec0 A0 n2) v'.

  (** vmul and vmul' are equivalent *)
  Lemma vmul_eq_vmul' : forall n1 n2 (v1 : vec n1) (v2 : vec n2), vmul v1 v2 == vmul' v1 v2.
  Proof.
    unfold vmul, vmul'.
    induction n1; intros; vsimp; simpl.
    - rewrite vcmul_0_l. easy.
    - rewrite vcmul_add_distr_r. f_equiv. auto.
  Qed.

End vec_alg.

(** ** Linear Space. These code is for test *)
Section LinearSpace.

  (** definition of Linear Space:
  V ~~ vec
  P ~~ A
  + ~~ vadd
  . ~~ vcmul/vmulc
   *)

  Open Scope A_scope.
  Open Scope vec_scope.

  (* dimension *)
  Variable n : nat.

  (* P *)
  Context `{R : Ring}.
  Add Ring ring_inst : make_ring_theory.

  Notation "- t" := (Aopp t) : A_scope.
  Infix "==" := Aeq : A_scope.
  Infix "+" := Aadd : A_scope.
  Infix "*" := Amul : A_scope.

  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "+" := (vadd (Aadd:=Aadd)) : vec_scope.
  Infix "c*" := (vcmul (Amul:=Amul)) : vec_scope.
  Infix "*c" := vmulc : vec_scope.

  (* (1), v1 + v2 = v2 + v1 *)
  Lemma Vadd_comm : forall (v1 v2 : vec n), v1 + v2 == v2 + v1.
  Proof.
    intros. apply vadd_comm.
  Qed.

  (* (2), (v1 + v2) + v3 = v1 + (v2 + v3) *)
  Lemma Vadd_assoc : forall (v1 v2 v3 : vec n), (v1 + v2) + v3 == v1 + (v2 + v3).
  Proof.
    intros. apply vmap2_assoc. apply monoidAssoc.
  Qed.

  (* (3), v + 0 = v *)
  Lemma Vadd_0_r : forall (v : vec n), v + (vec0 A0 n) == v.
  Proof.
    intros. apply vadd_0_r.
  Qed.

  (* (4), forall v1 in V, (exist v2, (v1 + v2 = 0)) *)
  Lemma Vopp_exist : forall (v1 : vec n), {v2 | v1 + v2 == vec0 A0 n}.
  Proof.
    destruct n; intros; vsimp; simpl. exists tt; auto.
    exists (-a, vmap Aopp v). simpl. split. ring.
    induction n0; vsimp; simpl; auto. split; auto. ring.
  Qed.

  (* (5) 1 . v = v *)
  Lemma Vcmul_1_l : forall (v : vec n), A1 c* v == v.
  Proof.
    intros. apply vcmul_1_l.
  Qed.

  (* (6) k . (m . v) = (km) . v *)
  Lemma Vcmul_assoc : forall (k m : A) (v : vec n), k c* (m c* v) == (k*m) c* v.
  Proof.
    unfold vcmul. induction n; intros; vsimp; simpl; auto. split; auto. ring.
  Qed.

  (* (7) (k + m) . v = k.v + m.v *)
  Lemma Vcmul_dist_c : forall (k m : A) (v : vec n),
      (k + m)%A c* v == (k c* v) + (m c* v).
  Proof.
    intros. apply vcmul_add_distr_r.
  Qed.

  (* (8) k . (v1 + v2) = k.v1 + k.v2 *)
  Lemma Vcmul_dist_v : forall (k : A) (v1 v2 : vec n),
      k c* (v1 + v2) == (k c* v1) + (k c* v2).
  Proof.
    intros. apply vcmul_add_distr_l.
  Qed.

End LinearSpace.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.Eqdep.

Require Import Category.
Require Import Functor.
Require Import NaturalTransformation.
Require Import FunctorCategory.
Require Import MetaCategory.
Require Import Diagrams.
Require Import Delta.

Polymorphic Record AdjointSig{A B: Cat}{F: Fun B A}{G: Fun A B} := {
  epsilon: NatTrans (funComp F G) (funId A);
  eta    : NatTrans (funId B) (funComp G F)
}.

Arguments AdjointSig {_ _} _ _.

Polymorphic Record AdjointAx{A B F G}(S: @AdjointSig A B F G): Prop := {
  foo: forall Y, eq_h (id (F Y)) (comp (epsilon S (F Y)) (fmap F (eta S Y)));
  bar: forall X, eq_h (comp (fmap G (epsilon S X)) (eta S (G X))) (id (G X))
}.

Polymorphic Record Adjoint{A B: Cat}{F: Fun B A}{G: Fun A B} := {
  adjointSig :> AdjointSig F G;
  adjointAx  :> AdjointAx adjointSig
}.


Require Import Undecidability.Axioms.EA.
Require Import Undecidability.Shared.Pigeonhole.
Require Import Undecidability.Shared.FinitenessFacts.
Require Import Undecidability.Synthetic.reductions Undecidability.Synthetic.truthtables.
Require Import Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.EnumerabilityFacts Undecidability.Synthetic.SemiDecidabilityFacts Undecidability.Synthetic.ReducibilityFacts.
Require Import Undecidability.Shared.ListAutomation.
Require Import List Arith.

Import ListNotations ListAutomationNotations.

Definition productive (p : nat -> Prop) := exists f : nat -> nat, forall c, (forall x, W c x -> p x) -> p (f c) /\ ~ W c (f c).

Lemma productive_nonenumerable p :
  productive p -> ~ enumerable p.
Proof.
  intros [f Hf] [c Hc] % W_spec.
  destruct (Hf c) as [H1 % Hc H2].
  eapply Hc. tauto.
Qed.

Lemma K0_productive :
  productive (compl K0).
Proof.
  exists (fun n => n). intros c H.
  specialize (H c). unfold K0, compl in *. tauto.
Qed.

Lemma productive_dedekind_infinite p :
  productive p -> dedekind_infinite p.
Proof.
  specialize List_id as [c_l c_spec]. intros [f Hf].
  eapply (weakly_generative_dedekind_infinite). econstructor.
  intros l.
  exists (f (c_l l)). intros Hl. split.
  - specialize (Hf (c_l l)).
    rewrite <- c_spec. eapply Hf.
    intros x. rewrite c_spec. eapply Hl.
  - eapply Hf. intros x. rewrite c_spec. eapply Hl.
Qed.

Lemma productive_subpredicate p :
  productive p ->
  exists q : nat -> Prop, enumerable q /\ dedekind_infinite q /\ (forall x, q x -> p x).
Proof.
  intros H.
  eapply dedekind_infinite_problem.
  eapply productive_dedekind_infinite. eauto.
Qed.

Lemma productive_red p q :
  p ⪯ₘ q -> productive p -> productive q.
Proof.
  intros [f Hf] [g Hg].
  specialize (SMN' f) as [k Hk].
  exists (fun c => f (g (k c))). intros c Hs.
  assert (Hkc : forall x, W (k c) x -> p x) by  (intros; now eapply Hf, Hs, Hk).
  split.
  - now eapply Hf, Hg.
  - intros ?. eapply Hg, Hk; eauto.
Qed.

Lemma many_one_complete_subpredicate p :
  m-complete p ->
  exists q : nat -> Prop, enumerable q /\ dedekind_infinite q /\ (forall x, q x -> compl p x).
Proof.
  intros Hcomp. eapply productive_subpredicate.
  eapply productive_red.
  - eapply red_m_complement. eapply Hcomp. eapply K0_enum.
  - eapply K0_productive.
Qed.

Definition simple (p : nat -> Prop) :=
  enumerable p /\ ~ exhaustible (compl p) /\ ~ exists q, enumerable q /\ ~ exhaustible q /\ (forall x, q x -> compl p x).

Lemma simple_non_enumerable p :
  simple p -> ~ enumerable (compl p).
Proof.
  intros (H1 & H2 & H3) H4.
  apply H3. eauto.
Qed.

Lemma simple_undecidable p :
  simple p -> ~ decidable p.
Proof.
  intros ? ? % decidable_complement % decidable_enumerable; eauto.
  now eapply simple_non_enumerable in H1.
Qed.

Lemma simple_m_incomplete p :
  simple p -> ~ m-complete p.
Proof.
  intros (H1 & H2 & H3) (q & Hq1 & Hq2 & Hq3) % many_one_complete_subpredicate.
  eapply H3. exists q; repeat split; eauto.
  now eapply unbounded_non_finite, dedekind_infinite_unbounded.
Qed.

Lemma non_finite_non_empty {X} (p : X -> Prop) :
  ~ exhaustible p -> ~~ exists x, p x.
Proof.
  intros H1 H2. apply H1. exists []. firstorder.
Qed.

Lemma simple_no_cylinder p :
  (fun '((x, n) : nat * nat) => p x) ⪯₁ p -> ~ simple p.
Proof.
  intros [f [inj_f Hf]] (H1 & H2 & H3). red in Hf.
  apply (non_finite_non_empty _ H2). intros [x0 Hx0].
  apply H3.
  exists (fun x => exists n, x = f (x0, n)). split. 2:split.
  - eapply semi_decidable_enumerable; eauto.
    exists (fun x n => Nat.eqb x (f (x0, n))).
    intros x. split; intros [n H]; exists n; destruct (Nat.eqb_spec x (f (x0, n))); firstorder congruence.
  - eapply unbounded_non_finite, dedekind_infinite_unbounded.
    exists (fun n => f (x0, n)). intros. split. eauto.
    now intros ? [=] % inj_f.
  - intros ? [n ->]. red. now rewrite <- (Hf (x0, n)).
Qed.


Require Import Tactics.Crush.
Require Import Tactics.Tactics.

(***
 * bool flag[2] = {false};
 * int turn = 0;
 *
 * void proc(int self) {
 *   flag[self] = true;                                    // P1
 *   turn = not(self);                                     // P2
 *   while (flag[not(self)] && turn == not(self)) {        // P3
 *     // busy wait
 *   }
 *   // critical section                                   // CS
 *   flag[self] = false;                                   // P4
 *   return;                                               // P5 (DONE!)
 * }
 ***)

Inductive Thread := Thread0 | Thread1.

Definition OtherThread (th : Thread) : Thread :=
  match th with
  | Thread0 => Thread1
  | Thread1 => Thread0
  end.

Inductive PC := P1 | P2 | P3 | P4 | P5 | CS.

Record State := {
  turn : Thread;
  flag : Thread -> bool;
  pc : Thread -> PC;  (** interpreted as before executing pc. *)
}.

Inductive StateInit : State -> Prop :=
| InitIntro :
    forall flag pc,
      (forall i, flag i = false /\ pc i = P1) ->
      StateInit {| turn := Thread0;
                   flag := flag;
                   pc := pc |}.

Inductive StateStep : State -> State -> Prop :=
| StepP1 :
    forall i turn flag flag' pc pc',
      pc i = P1 ->
      pc' i = P2 /\ pc' (OtherThread i) = pc (OtherThread i) ->
      flag' i = true /\ flag' (OtherThread i) = flag (OtherThread i) ->
      StateStep {| turn := turn;
                   flag := flag;
                   pc := pc |}
                {| turn := turn;
                   flag := flag';
                   pc := pc' |}

| StepP2 :
    forall i turn turn' flag pc pc',
      pc i = P2 ->
      pc' i = P3 /\ pc' (OtherThread i) = pc (OtherThread i) ->
      turn' = OtherThread i ->
      StateStep {| turn := turn;
                   flag := flag;
                   pc := pc |}
                {| turn := turn';
                   flag := flag;
                   pc := pc' |}

| StepFailP3 :
    forall i turn flag pc pc',
      pc i = P3 ->
      flag (OtherThread i) = true /\ turn = OtherThread i ->
      pc' i = P3 /\ pc' (OtherThread i) = pc (OtherThread i) ->
      StateStep {| turn := turn;
                   flag := flag;
                   pc := pc |}
                {| turn := turn;
                   flag := flag;
                   pc := pc' |}

| StepP3 :
    forall i turn flag pc pc',
      pc i = P3 ->
      ~ (flag (OtherThread i) = true /\ turn = OtherThread i) ->
      pc' i = CS /\ pc' (OtherThread i) = pc (OtherThread i) ->
      StateStep {| turn := turn;
                   flag := flag;
                   pc := pc |}
                {| turn := turn;
                   flag := flag;
                   pc := pc' |}

| StepCS :
    forall i turn flag pc pc',
      pc i = CS ->
      pc' i = P4 /\ pc' (OtherThread i) = pc (OtherThread i) ->
      StateStep {| turn := turn;
                   flag := flag;
                   pc := pc |}
                {| turn := turn;
                   flag := flag;
                   pc := pc' |}

| StepP4 :
    forall i turn flag flag' pc pc',
      pc i = P4 ->
      pc' i = P5 /\ pc' (OtherThread i) = pc (OtherThread i) ->
      flag' i = false /\ flag' (OtherThread i) = flag (OtherThread i) ->
      StateStep {| turn := turn;
                   flag := flag;
                   pc := pc |}
                {| turn := turn;
                   flag := flag';
                   pc := pc' |}.

Inductive StateMultiStep : State -> State -> Prop :=
| StateMultiStep0 :
    forall state,
      StateMultiStep state state
| StateMultiStep1 :
    forall state state1 state2,
      StateStep state1 state2 ->
      StateMultiStep state state1 ->
      StateMultiStep state state2.

Definition MutualExclusion state : Prop :=
  let pc := state.(pc) in
  ~ (pc Thread0 = CS /\ pc Thread1 = CS).

Definition Invariant state :=
  let pc := state.(pc) in
  let flag := state.(flag) in
  let turn := state.(turn) in
  forall i,
    (
      pc i = P2 \/ pc i = P3 \/ pc i = CS \/ pc i = P4 ->
      flag i = true
    ) /\
    (
      pc i = CS ->
      (
        pc (OtherThread i) <> CS /\
        (pc (OtherThread i) = P3 -> turn = i)
      )
    ).

Lemma InvariantImpliesMutualExclusion :
  forall state,
    Invariant state -> MutualExclusion state.
Proof.
  intros; unfold Invariant, MutualExclusion in *.
  pose proof (H Thread0); pose proof (H Thread1).
  crush.
Qed.

Lemma InitStateSatisfiesInvariant :
  forall state,
    StateInit state -> Invariant state.
Proof.
  intros; inversion H; unfold Invariant.
  pose proof (H0 Thread0); pose proof (H0 Thread1).
  intros; destruct i; crush.
Qed.

Lemma StateStepKeepsInvariant :
  forall state state',
    StateStep state state' ->
    Invariant state ->
    Invariant state'.
Proof.
  intros; unfold Invariant in *; invert H;
    intros; simpl in *;
    pose proof (H0 Thread0); pose proof (H0 Thread1); crush;
    repeat (
        match goal with
        | [ t : Thread |- _ ] => destruct t
        | [ H : ?pc1 _ = ?pc2 _ |- _ ] => rewrite H in *
        end; crush
    ).
Qed.

Lemma Safety' :
  forall state state',
    StateMultiStep state state' ->
    Invariant state ->
    Invariant state'.
Proof.
  induction 1; intros.
  + auto.
  + eapply StateStepKeepsInvariant; eauto.
Qed.

Theorem Safety :
  forall state state',
    StateMultiStep state state' ->
    StateInit state ->
    MutualExclusion state'.
Proof.
  intros.
  apply InvariantImpliesMutualExclusion.
  apply InitStateSatisfiesInvariant in H0.
  eapply Safety'; eauto.
Qed.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Language LibTactics.

Set Printing Parentheses.

Inductive proper_typ : typ -> Prop :=
| pt_int : proper_typ typ_int
| pt_top : proper_typ typ_top
| pt_ord_fun : forall (A B : typ),
    ordinary B -> proper_typ A -> proper_typ B ->
    proper_typ (typ_arrow A B)
| pt_split : forall (A B C : typ),
    splitable A B C -> proper_typ B -> proper_typ C ->
    proper_typ A.

Hint Constructors proper_typ : core.

Lemma proper_typ_arrow :
  forall (A B : typ),
    proper_typ A -> proper_typ B ->
    proper_typ (typ_arrow A B).
Proof.
  intros * H1 H2.
  gen A.
  induction H2; eauto.
Qed.

Hint Resolve proper_typ_arrow : core.

Lemma proper_typ_complete :
  forall (A : typ), proper_typ A.
Proof.
  induction A; eauto.
Qed.

Ltac proper_ind A := assert (r: proper_typ A)
    by apply (proper_typ_complete A); induction r.

Lemma split_and_ord :
  forall (A A1 A2 : typ),
    splitable A A1 A2 -> ordinary A -> False.
Proof.
  introv Hsp Hord. gen A1 A2.
  dependent induction Hord; intros; try solve [inversion Hsp; eauto]; eauto.
Qed.

Hint Resolve split_and_ord : core.

Lemma split_or_ord :
  forall (A : typ),
    ordinary A \/ exists B C, splitable A B C.
Proof.
  introv. dependent induction A; eauto.
  destruct IHA1; destruct IHA2; eauto.
  - right. destruct_conjs; eauto.
  - right. destruct_conjs; eauto.
Qed.

Lemma sub_arrow_gen :
  forall (A B C D : typ),
    sub B D -> sub C A -> sub (typ_arrow A B) (typ_arrow C D).
Proof.
  introv H. dependent induction H; eauto.
Qed.

Hint Resolve sub_arrow_gen : core.

Lemma sub_and_l_gen :
  forall (A B C : typ),
    sub A C -> sub (typ_and A B) C.
Proof.
  introv H.
  dependent induction H; eauto.
Qed.

Lemma sub_and_r_gen :
  forall (A B C : typ),
    sub B C -> sub (typ_and A B) C.
Proof.
  introv H.
  dependent induction H; eauto.
Qed.

Hint Resolve sub_and_l_gen : core.
Hint Resolve sub_and_r_gen : core.

Lemma sub_reflexivity:
  forall (A : typ), sub A A.
Proof.
  induction A; eauto.
Qed.

Hint Resolve sub_reflexivity : core.

Lemma splitable_sub_l :
  forall (A B C : typ),
    splitable A B C -> sub A B.
Proof.
  introv H. dependent induction H; eauto.
Qed.

Lemma splitable_sub_r :
  forall (A B C : typ),
    splitable A B C -> sub A C.
Proof.
  introv H. dependent induction H; eauto.
Qed.

Hint Resolve splitable_sub_l : core.
Hint Resolve splitable_sub_r : core.

Lemma splitable_iso :
  forall (A B C : typ),
    splitable A B C -> sub A (typ_and B C) /\ sub (typ_and B C) A.
Proof.
  introv H.
  split.
  - eapply sub_and; eauto.
  - dependent induction H; eauto.
Qed.

Hint Resolve splitable_iso : core.

Lemma split_determinism :
  forall (T A1 A2 B1 B2 : typ),
    splitable T A1 B1 -> splitable T A2 B2 ->
    A1 = A2 /\ B1 = B2.
Proof.
  introv Hsp1 Hsp2.
  gen A2 B2.
  dependent induction Hsp1; eauto; intros.
  - dependent destruction Hsp2.
    split; eauto.
  - dependent destruction Hsp2.
    pose proof IHHsp1; eauto.
    assert (C = C0 /\ D = D0); eauto.
    destruct_conjs. split; congruence.
Qed.

Lemma sub_inversion_split_l :
  forall (A B A1 A2 : typ),
    sub A B -> splitable A A1 A2 -> ordinary B -> sub A1 B \/ sub A2 B.
Proof.
  intros. gen A1 A2.
  set (Case := A <: B).
  induction H; eauto; intros.
  - inversion H0.
  - dependent destruction H3.
    eapply IHsub2 in H2; eauto.
    destruct H2; eauto.
  - eapply split_and_ord in H1; eauto. inversion H1.
  - dependent destruction H2.
    left. assumption.
  - dependent destruction H2.
    right. assumption.
Qed.

Print HintDb core.

Lemma sub_inversion_split_r :
  forall (A B B1 B2 : typ),
    sub A B -> splitable B B1 B2 -> sub A B1 /\ sub A B2.
Proof.
  intros * Hsub Hspl.
  dependent destruction Hsub; try solve [eauto | exfalso; eauto].
  eapply split_determinism in H; eauto.
  intuition; subst; eauto.
Qed.

Lemma toplike_spl_combine :
  forall (A B C : typ),
    splitable A B C -> toplike B -> toplike C -> toplike A.
Proof.
  introv Hspl Htl1 Htl2.
  dependent induction Hspl; eauto.
  dependent destruction Htl1.
  dependent destruction Htl2.
  eapply tl_arrow. eapply IHHspl; eauto.
Qed.

Lemma sub_toplike_preservation :
  forall (A B : typ),
    toplike A -> sub A B -> toplike B.
Proof.
  introv Htl Hsub.
  dependent induction Hsub; try solve [inversion Htl]; eauto.
  - dependent destruction Htl; eauto.
  - eapply toplike_spl_combine; eauto.
  - dependent destruction Htl; eauto.
  - dependent destruction Htl; eauto.
Qed.

Lemma sub_transitivity:
  forall (B A C : typ),
    sub A B -> sub B C -> sub A C.
Proof.
  intros * Hs1 Hs2.
  gen A C.
  proper_ind B; intros.
  - dependent induction Hs2; eauto.
  - dependent induction Hs2; eauto.
  - dependent induction Hs2; eauto.
    clear IHHs2_1 IHHs2_2.
    dependent induction Hs1; try solve [eauto | exfalso; eauto].
    + dependent destruction H1; eauto.
      assert (toplike D); eauto.
      eapply sub_toplike_preservation; eauto.
  - gen A B.
    proper_ind C0; introv Hs1 Hs2 Hspl Hrb IH; eauto.
    + eapply sub_inversion_split_r in Hs1; eauto.
      destruct Hs1.
      eapply sub_inversion_split_l in Hs2; eauto.
      destruct Hs2; eauto.
    + eapply sub_inversion_split_r in Hs1; eauto.
      destruct Hs1.
      eapply sub_inversion_split_l in Hs2; eauto.
      destruct Hs2; eauto.
    + eapply sub_inversion_split_r in Hs2; eauto.
      destruct Hs2; eauto.
Qed.

Lemma sub_arrow_int_false :
  forall (A B : typ),
    sub (typ_arrow A B) typ_int -> False.
Proof.
  introv H.
  dependent destruction H; eauto.
  inversion H0.
Qed.

Hint Resolve sub_arrow_int_false : core.

Lemma toplike_or_not_toplike :
  forall (A : typ),
    toplike A \/ not (toplike A).
Proof.
  intros A.
  induction A;
    try solve [right; intros Hcontra; inversion Hcontra]; eauto.
  - destruct IHA1; destruct IHA2; eauto.
    + right; intros H1; dependent destruction H1; contradiction.
    + right; intros H1; dependent destruction H1; contradiction.
  - destruct IHA1; destruct IHA2; eauto.
    + right; intros H1; dependent destruction H1; contradiction.
    + right; intros H1; dependent destruction H1; contradiction.
    + right; intros H1; dependent destruction H1; contradiction.
Qed.

Lemma split_and_not_toplike :
  forall (A B C : typ),
    not (toplike A) -> splitable A B C ->
    not (toplike B) \/ not (toplike C).
Proof.
  introv Hntl Hspl.
  gen B C.
  induction A; intros.
  - inversion Hspl.
  - inversion Hspl.
  - dependent destruction Hspl.
    assert (not (toplike C) \/ not (toplike D)); eauto.
    destruct H.
    + left. intros Hcontra. dependent destruction Hcontra. contradiction.
    + right. intros Hcontra. dependent destruction Hcontra. contradiction.
  - dependent destruction Hspl.
    destruct (toplike_or_not_toplike A1);
    destruct (toplike_or_not_toplike A2); eauto.
Qed.

Lemma sub_int_arrow_false :
  forall (A B : typ),
    not (toplike B) ->
    sub typ_int (typ_arrow A B) ->
    False.
Proof.
  introv Htl Hsub.
  dependent induction Hsub; eauto.
  - dependent destruction H0. contradiction.
  - dependent destruction H.
    destruct (toplike_or_not_toplike C); eauto.
    destruct (toplike_or_not_toplike D); eauto.
    eapply split_and_not_toplike in H; eauto.
    intuition.
Qed.

Theorem sub_int_form :
  forall (A : typ),
    sub typ_int A -> not (toplike A) -> ordinary A -> A = typ_int.
Proof.
  introv Hsub Htl Hord.
  dependent induction Hord; eauto.
  - destruct Htl; eauto.
  - dependent destruction Hsub.
    + contradiction.
    + dependent destruction H.
      exfalso; eauto.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_Twenty.

Coq < Goal forall w x q r s f g h:Prop, (((w /\ x) -> (q \/ r)) /\ ((s \/ f) /\ (q \/ w)) /\ ((s \/ g) -> (~q -> x)) /\ (q \/ s) /\ (~q /\ h)) -> (r).
1 subgoal

  ============================
   forall w x q r s f g h : Prop,
   (w /\ x -> q \/ r) /\
   ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h ->
   r

Unnamed_thm < intros.
1 subgoal

  w : Prop
  x : Prop
  q : Prop
  r : Prop
  s : Prop
  f : Prop
  g : Prop
  h : Prop
  H : (w /\ x -> q \/ r) /\
      ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h
  ============================
   r

Unnamed_thm < elim H.
1 subgoal

  w : Prop
  x : Prop
  q : Prop
  r : Prop
  s : Prop
  f : Prop
  g : Prop
  h : Prop
  H : (w /\ x -> q \/ r) /\
      ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h
  ============================
   (w /\ x -> q \/ r) ->
   ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h ->
   r

Unnamed_thm < intro.
1 subgoal

  w : Prop
  x : Prop
  q : Prop
  r : Prop
  s : Prop
  f : Prop
  g : Prop
  h : Prop
  H : (w /\ x -> q \/ r) /\
      ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h
  H0 : w /\ x -> q \/ r
  ============================
   ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h ->
   r

Unnamed_thm < intro.
1 subgoal

  w : Prop
  x : Prop
  q : Prop
  r : Prop
  s : Prop
  f : Prop
  g : Prop
  h : Prop
  H : (w /\ x -> q \/ r) /\
      ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h
  H0 : w /\ x -> q \/ r
  H1 : ((s \/ f) /\ (q \/ w)) /\ (s \/ g -> ~ q -> x) /\ (q \/ s) /\ ~ q /\ h
  ============================
   r

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_Twenty.
Goal forall w x q r s f g h:Prop, (((w /\ x) -> (q \/ r)) /\ ((s \/ f) /\ (q \/ w)) /\ ((s \/ g) -> (~q -> x)) /\ (q \/ s) /\ (~q /\ h)) -> (r).
intros.
elim H.
intro.
intro.
firstorder.
Qed.