(** * Sets built with lists *)

Set Implicit Arguments.

Require Import List.
From Cyclic_PA.Casteran Require Import more_list.
From Cyclic_PA.Casteran Require Import list_permut.
Require Import Arith.

Module Type S.

Declare Module DS : decidable_set.S.

Definition elt := DS.A.
Definition eq_elt_dec := DS.eq_A_dec.

Fixpoint without_red (l : list elt) {struct l} : Prop :=
  match l with
  | nil => True
  | e :: le => if (In_dec eq_elt_dec e le) then False else without_red le
  end.

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

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

Definition subset s1 s2 : Prop :=
  forall e, In e s1.(support) -> In e s2.(support).

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

End S.

(** ** Definition of sets using lists. *)
Module Make (DS1 : decidable_set.S) <: S with Module DS:= DS1.

Module DS := DS1.
Import DS1.
Module LP := list_permut.Make (DS1).

Definition elt := DS.A.
Definition eq_elt_dec : forall t1 t2 : elt, {t1 = t2} + {t1 <> t2} := DS.eq_A_dec.

(*** Property of being without redundancy for lists of elements, intended as sets. *)
Fixpoint without_red (l : list elt) {struct l} : Prop :=
  match l with
  | nil => True
  | e :: le => if (In_dec eq_elt_dec e le) then False else without_red le
  end.

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

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

Lemma mem_dec : forall e s, {mem e s}+{~mem e s}.
Proof.
intros e s; unfold mem; apply (In_dec eq_elt_dec).
Qed.

Lemma add_prf :
  forall e l, without_red l -> ~In e l -> without_red (e :: l).
Proof.
intros e l Wl e_not_in_l; simpl;
destruct (In_dec eq_elt_dec e l) as [e_in_l | _]; trivial;
apply e_not_in_l; trivial.
Qed.

Definition add e s :=
  match In_dec eq_elt_dec e s.(support) with
  | left _ => s
  | right R => mk_set (e :: s.(support)) (add_prf e s.(support) s.(is_a_set) R)
  end.

Lemma add_1 : forall e s, mem e (add e s).
Proof.
intros e s; unfold mem, add; simpl;
destruct (In_dec eq_elt_dec e (support s)) as [e_in_s | e_not_in_s].
trivial.
left; trivial.
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;
destruct (In_dec eq_elt_dec e' (support s)) as [e'_in_s | e'_not_in_s].
trivial.
right; trivial.
Qed.

Lemma add_12 : forall e e' s, mem e (add e' s) -> e = e' \/ mem e s.
Proof.
intros e e' s; unfold mem, add; simpl;
destruct (In_dec eq_elt_dec e' (support s)) as [e'_in_s | e'_not_in_s].
right; trivial.
intros [e'_eq_e | e_in_s]; [left; subst | right]; trivial.
Qed.

Fixpoint filter_aux (P : elt -> Prop) (P_dec : forall e, {P e}+{~ P e})
   (l : list elt) {struct l} : list elt :=
  match l with
  | nil => nil
  | e :: le =>
           if (P_dec e)
           then e :: (filter_aux P P_dec le)
           else filter_aux P P_dec le
   end.

(*** Properties of filter. *)
Lemma included_filter_aux :
forall P P_dec e l, In e (filter_aux P P_dec l) -> In e l.
Proof.
intros P P_dec x l; induction l as [ | e le ].
contradiction.
simpl; destruct (P_dec e) as [ _ | _].
intros [x_eq_e | x_in_rrle]; simpl.
left; trivial.
right; apply IHle; trivial.
intro; right; apply IHle; trivial.
Qed.

Lemma without_red_filter_aux :
  forall P P_dec l, without_red l -> without_red (filter_aux P P_dec l).
Proof.
intros P P_dec l; induction l as [ | e le]; simpl; trivial.
destruct (P_dec e) as [ _ | _ ];
destruct (In_dec eq_elt_dec e le) as [ in_e_le | not_in_e_le];
trivial; try contradiction.
simpl;
destruct (In_dec eq_elt_dec e (filter_aux P P_dec le)) as [ in_e_rrle | _];
trivial;
absurd (In e le); trivial.
apply included_filter_aux with P P_dec; trivial.
Qed.

Definition filter P P_dec s :=
   mk_set (filter_aux P P_dec s.(support))
               (without_red_filter_aux P P_dec _ s.(is_a_set)).

Lemma filter_1_list :
  forall (P : elt -> Prop) P_dec l e, In e l -> P e -> In e (filter_aux P P_dec l).
Proof.
intros P P_dec l; induction l as [ | e' l ].
contradiction.
intros e [e_eq_e' | e_in_l] Pe.
subst e'; simpl.
destruct (P_dec e) as [ _ | not_Pe].
left; trivial.
absurd (P e); trivial.
simpl; destruct (P_dec e') as [ _ | _ ]; [ right | idtac ]; apply IHl; trivial.
Qed.

Lemma filter_1 :
  forall (P : elt -> Prop) P_dec s e, mem e s -> P e -> mem e (filter P P_dec s).
Proof.
unfold mem, support;
intros P P_dec [l wr] e e_in_s P_e; simpl;  apply filter_1_list; trivial.
Qed.

Lemma filter_2_list :
 forall (P : elt -> Prop) P_dec l e, In e (filter_aux P P_dec l) ->
                In e l /\ P e.
Proof.
intros P P_dec l; induction l as [ | e' l].
contradiction.
intros e; simpl; destruct (P_dec e') as [ Pe' | not_Pe' ].
intros [e_eq_e' | e_in_fltl].
subst; split; trivial; left; trivial.
generalize (IHl _ e_in_fltl); intros [e_in_l Pe]; split; trivial; right; trivial.
intro e_in_fltl;
generalize (IHl _ e_in_fltl); intros [e_in_l Pe]; split; trivial; right; trivial.
Qed.

Lemma filter_2 :
 forall (P : elt -> Prop) P_dec s e, mem e (filter P P_dec s) ->
                mem e s /\ P e.
Proof.
unfold mem, support;
intros P P_dec [l wr] e e_in_l_and_P_e; apply filter_2_list with P_dec; trivial.
Qed.

(*** How to remove redundancies from a list with remove_red. *)
Fixpoint remove_red (l : list elt) : list elt :=
  match l with
  | nil => nil
  | e :: le =>
           if (In_dec eq_elt_dec e le)
           then remove_red le
           else e :: (remove_red le)
   end.

Lemma included_remove_red :
forall e l, In e (remove_red l) -> In e l.
Proof.
intros x l; induction l as [ | e le ].
contradiction.
simpl; destruct (In_dec eq_elt_dec e le) as [ _ | _].
intro; right; apply IHle; trivial.
intros [x_eq_e | x_in_rrle]; simpl.
left; trivial.
right; apply IHle; trivial.
Qed.

Lemma remove_red_included : forall e l, In e l -> In e (remove_red l).
Proof.
intros x l; induction l as [ | e le ].
contradiction.
intros [x_eq_e | x_in_le]; simpl.
subst x; destruct (In_dec eq_elt_dec e le) as [ in_e_le | not_in_e_le];
[ apply IHle | left ]; trivial.
destruct (In_dec eq_elt_dec e le) as [ in_e_le | not_in_e_le];
[ idtac | right]; apply IHle; trivial.
Qed.

Lemma without_red_remove_red :  forall l, without_red (remove_red l).
Proof.
intro l; induction l as [ | e le]; simpl; trivial.
destruct (In_dec eq_elt_dec e le) as [ in_e_le | not_in_e_le]; trivial.
simpl;
destruct (In_dec eq_elt_dec e (remove_red le)) as [ in_e_rrle | _];
trivial;
absurd (In e le); trivial; apply included_remove_red; trivial.
Qed.

Lemma without_red_remove :
  forall e l1 l2, without_red (l1 ++ e :: l2) -> without_red (l1 ++ l2).
Proof.
intros e l1; generalize e; clear e; induction l1 as [ | e1 l1];
intros e l2; simpl.
destruct (In_dec eq_elt_dec e l2); trivial; contradiction.
destruct (In_dec eq_elt_dec e1 (l1 ++ e :: l2)) as [ | not_in_e1].
contradiction.
destruct (In_dec eq_elt_dec e1 (l1 ++ l2)) as [ in_e1 | _].
intros _; apply not_in_e1;
generalize (@in_app_or _ _ _ _ in_e1); clear in_e1; intros [ in_e1 | in_e1];
apply in_or_app; [left | right; right]; trivial.
intro; apply (IHl1 e l2); trivial.
Qed.

Lemma without_red_add :
  forall e l1 l2, without_red (l1 ++ l2) -> ~In e (l1 ++ l2) ->
  without_red (l1 ++ e :: l2).
Proof.
intros e l1; generalize e; clear e; induction l1 as [ | e1 l1];
intros e l2 wr12 e_not_in_l1_l2.
simpl; destruct (In_dec eq_elt_dec e l2) as [e_in_l2 | _]; trivial.
absurd (In e l2); trivial.
simpl.
destruct (In_dec eq_elt_dec e1 (l1 ++ e :: l2))
    as [e1_in_l1_e_l2 | e_not_in_l1_e_l2].
destruct (in_app_or _ _ _ e1_in_l1_e_l2) as [e1_in_l1 | [e1_eq_e | e1_in_l2]].
simpl in wr12;
destruct (In_dec eq_elt_dec e1 (l1 ++ l2)) as [e1_in_l1_l2 | e1_not_in_l1_l2].
trivial.
absurd (In e1 (l1 ++ l2)); trivial; apply in_or_app; left; trivial.
subst e; absurd (In e1 ((e1 :: l1) ++ l2)); trivial; left; trivial.
simpl in wr12;
destruct (In_dec eq_elt_dec e1 (l1 ++ l2)) as [e1_in_l1_l2 | e1_not_in_l1_l2].
trivial.
absurd (In e1 (l1 ++ l2)); trivial; apply in_or_app; right; trivial.

apply IHl1.
apply (without_red_remove e1 nil (l1 ++ l2)); trivial.
intro e_in_l1_l2; apply e_not_in_l1_l2; right; trivial.
Qed.

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

Definition empty : t :=
  mk_set nil without_red_nil.

(*** Singleton *)
Lemma without_red_singleton : forall e : elt, without_red (e :: nil).
Proof.
intro e; simpl; destruct (In_dec eq_elt_dec e nil); trivial.
Qed.

Definition singleton (e : elt) : t :=
  mk_set (e :: nil) (without_red_singleton e).

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

(*** Union of sets. *)
Fixpoint add_without_red (acc l : list elt) {struct l} : list elt :=
  match l with
  | nil => acc
  | e :: le =>
     if (In_dec eq_elt_dec 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.
intros l1 l2; generalize l1; clear l1; induction l2 as [ | e le];
intros l1 wr1; simpl; trivial.
destruct (In_dec eq_elt_dec e l1) as [ _ | not_in_e_l1];
apply IHle; trivial.
simpl; destruct (In_dec eq_elt_dec e l1) as [ in_e_l1 | _]; trivial;
absurd (In e l1); trivial.
Defined.

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

Lemma union_1_aux :
forall (l1 l2 : list elt) (e : elt), In e l1 -> In e (add_without_red l1 l2).
Proof.
intros l1 l2; generalize l1; clear l1; induction l2 as [ | e2 l2].
intros; trivial.
intros l1 e e_in_l1; simpl; case ( In_dec eq_elt_dec e2 l1); intro; apply IHl2; trivial.
right; trivial.
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 elt) (e : elt), In e l2 -> In e (add_without_red l1 l2).
Proof.
intros l1 l2; generalize l1; clear l1; induction l2 as [ | e2 l2];
intros l1 e e_in_e2l2.
contradiction.
simpl; destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1];
destruct e_in_e2l2 as [e_eq_e2 | e_in_l2].
subst; apply union_1_aux; trivial.
apply IHl2; trivial.
subst; apply union_1_aux; left; trivial.
apply IHl2; trivial.
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 elt) (e : elt), In e (add_without_red l1 l2) -> In e l1 \/ In e l2.
Proof.
intros l1 l2; generalize l1; clear l1; induction l2 as [ | e2 l2];
intros l1 e; simpl.
intro; left; trivial.
destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
intro H; generalize (IHl2 _ _ H); intuition.
intro H; generalize (IHl2 _ _ H); simpl; intuition.
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.

Fixpoint remove_not_common (acc l1 l2 : list elt) {struct l2} : list elt :=
  match l2 with
  | nil => acc
  | e :: l =>
      if In_dec eq_elt_dec e l1
      then remove_not_common (e :: acc) l1 l
      else remove_not_common acc l1 l
  end.

Lemma without_red_remove_not_common_aux :
  forall acc l1 l2, (forall e, In e acc /\ In 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; generalize acc l1; clear acc l1; induction l2 as [ | e2 l2].
intros; trivial.
intros acc l1 H wra wr1 wr2; simpl;
destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ];
apply IHl2; trivial.
intros e [[e_eq_e2 | e_in_acc] e_in_l2].
subst e; simpl in wr2;
destruct (In_dec eq_elt_dec e2 l2) as [ _ | e2_not_in_l2]; trivial;
absurd (In e2 l2); trivial.
apply (H e); split; trivial; right; trivial.
simpl; destruct (In_dec eq_elt_dec e2 acc) as [ e2_in_acc | _]; trivial.
apply (H e2); split; trivial; left; trivial.
apply (without_red_remove e2 nil l2); trivial.
intros e [e_in_acc e_in_l2]; apply (H e); split; trivial; right; trivial.
apply (without_red_remove e2 nil l2); trivial.
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.
simpl; trivial.
Qed.

Definition inter s1 s2 :=
  mk_set (remove_not_common nil s1.(support) s2.(support))
               (without_red_remove_not_common _ _ s1.(is_a_set) s2.(is_a_set)).

Lemma inter_1_aux :
  forall acc l1 l2 e, In e (remove_not_common acc l1 l2) -> In e acc \/ In e l1.
Proof.
intros acc l1 l2; generalize acc l1; clear acc l1; induction l2 as [ | e2 l2].
intros acc l1; simpl; intros; left; trivial.
intros acc l1 e; simpl;
destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
intros H; destruct (IHl2 _ _ _ H) as [[ e2_eq_e | e_in_acc ] | e_in_l1 ]; clear H.
subst; right; trivial.
left; trivial.
right; trivial.
intros H; apply IHl2; 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, In e (remove_not_common acc l1 l2) -> In e acc \/ In e l2.
Proof.
intros acc l1 l2; generalize acc l1; clear acc l1; induction l2 as [ | e2 l2].
intros acc l1; simpl; intros; left; trivial.
intros acc l1 e; simpl;
destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
intros H; destruct (IHl2 _ _ _ H) as [[ e2_eq_e | e_in_acc ] | e_in_l2 ]; clear H.
right; left; trivial.
left; trivial.
right; right; trivial.
intros H; destruct (IHl2 _ _ _ H) as [ e_in_acc  | e_in_l2 ]; clear H.
left; trivial.
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,  In e l1 -> In e l2 -> In e (remove_not_common acc l1 l2).
Proof.
assert (H : forall acc l1 l2 e, In e acc -> In e (remove_not_common acc l1 l2)).
intros acc l1 l2; generalize acc l1; clear acc l1; induction l2 as [ | e2 l2].
intros; simpl; trivial.
intros acc l1 e e_in_acc; simpl;
destruct (In_dec eq_elt_dec e2 l1) as [ _ | e2_not_in_l1 ].
apply IHl2; right; trivial.
apply IHl2; trivial.

intros acc l1 l2; generalize acc l1; clear acc l1; induction l2 as [ | e2 l2].
intros; contradiction.
intros acc l1 e e_in_l1 [ e_eq_e2 | e_in_l2 ]; simpl;
destruct (In_dec eq_elt_dec e2 l1) as [ _ | e2_not_in_l1 ].
subst e; apply H; left; trivial.
subst e; absurd (In e2 l1); trivial.
apply IHl2; trivial.
apply IHl2; 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.
intros [l1 wr1]; induction l1 as [ | e1 l1]; intros [l2 wr2].
left; intro e; contradiction.
destruct (In_dec eq_elt_dec e1 l2) as [ e1_in_l2 | e1_not_in_l2 ].
assert (wr1' := without_red_remove e1 nil l1 wr1); simpl in wr1'.
destruct (IHl1 wr1' (mk_set l2 wr2)) as [ s1_incl_s2 | s1_not_incl_s2 ].
left; intros e [e_eq_e1 | e_in_l1]; [subst | apply s1_incl_s2]; trivial.
right; intro H; apply s1_not_incl_s2; intros e e_in_l1; apply H; right; trivial.
right; intro H; apply e1_not_in_l2; apply H; left; trivial.
Qed.

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_comm :
  forall e1 e2 s, eq_set (add e1 (add e2 s)) (add e2 (add e1 s)).
Proof.
intros e1 e2 s e; split; intro H.
destruct (add_12 _ _ _ H) as [e_eq_e1 | e_in_e2_s].
apply add_2; subst; apply add_1.
destruct (add_12 _ _ _ e_in_e2_s) as [e_eq_e2 | e_in_s].
subst; apply add_1.
do 2 apply add_2; trivial.
destruct (add_12 _ _ _ H) as [e_eq_e2 | e_in_e1_s].
apply add_2; subst; apply add_1.
destruct (add_12 _ _ _ e_in_e1_s) as [e_eq_e1 | e_in_s].
subst; apply add_1.
do 2 apply add_2; trivial.
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 filter_union :
  forall P P_dec s1 s2,
  eq_set (filter P P_dec (union s1 s2))  (union (filter P P_dec s1) (filter P P_dec s2)).
Proof.
intros P P_dec [l1 wr1] [l2 wr2] e; split;
unfold mem, union, support; simpl; generalize l1 e; clear l1 wr1 wr2 e;
induction l2 as [ | e2 l2];
intros l1 e; trivial.
intro H; simpl in H; destruct (In_dec eq_elt_dec e2 l1) as [e2_in_l1 | e2_not_in_l1].
simpl; destruct (P_dec e2) as [P_e2 | not_P_e2].
simpl; destruct (In_dec eq_elt_dec e2 (filter_aux P P_dec l1))
 as [e2_in_l1_and_P_e2 | not_e2_in_l1_and_P_e2].
intros; apply IHl2; trivial.
absurd (In e2 (filter_aux P P_dec l1)); trivial; refine (filter_1_list _ _ _ _ _ _); trivial.
intros; apply IHl2; trivial.
generalize (IHl2 _ _ H); simpl; destruct (P_dec e2) as [P_e2 | not_P_e2].
simpl; destruct (In_dec eq_elt_dec e2 (filter_aux P P_dec l1))
 as [e2_in_l1_and_P_e2 | not_e2_in_l1_and_P_e2]; [idtac | trivial].
absurd (In e2 l1); trivial; generalize (filter_2_list _ _ _ _ e2_in_l1_and_P_e2); intuition.
trivial.

simpl; destruct (P_dec e2) as [P_e2 | not_P_e2].
destruct (In_dec eq_elt_dec e2 l1) as [e2_in_l1 | e2_not_in_l1].
simpl; destruct (In_dec eq_elt_dec e2 (filter_aux P P_dec l1))
 as [e2_in_l1_and_P_e2 | not_e2_in_l1_and_P_e2].
intros; apply IHl2; trivial.
absurd (In e2 (filter_aux P P_dec l1)); trivial; refine (filter_1_list _ _ _ _ _ _); trivial.
generalize (IHl2 (e2 :: l1) e); simpl; destruct (P_dec e2) as [_ | not_P_e2].
destruct (In_dec eq_elt_dec e2 (filter_aux P P_dec l1))
 as [e2_in_l1_and_P_e2 | not_e2_in_l1_and_P_e2]; [idtac | trivial].
absurd (In e2 l1); trivial; generalize (filter_2_list _ _ _ _ e2_in_l1_and_P_e2); intuition.
absurd (P e2); trivial.
destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
intro; apply IHl2; trivial.
intro H; refine (IHl2 (e2 :: l1) e _);
destruct (union_12_aux _ _ _ H) as [ H1 | H2 ].
apply union_1_aux; simpl; destruct (P_dec e2) as [ P_e2 | _]; trivial;
absurd (P e2); trivial.
apply union_2_aux; trivial.
Qed.

Lemma subset_filter :
  forall (P1 P2 : elt -> Prop) P1_dec P2_dec s1 s2, subset s1 s2 ->
  (forall e, P1 e -> P2 e) -> subset (filter P1 P1_dec s1) (filter P2 P2_dec s2).
Proof.
intros P1 P2 P1_dec P2_dec s1 s2 Hs HP e H;
generalize (filter_2 _ _ _ _ H); intros [e_in_s1 P1_e].
apply filter_1; [ apply (Hs e) | apply HP ]; 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_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.
intros [l1 wr1]; induction l1 as [ | e le];
intros s2 H; unfold cardinal; simpl.
apply le_O_n.
assert (In_e_s2 : In e s2.(support)). apply H; left; trivial.
generalize (split_list_app_cons eq_elt_dec _ _ In_e_s2).
destruct (split_list eq_elt_dec (support s2) e) as [l2' l2'']; clear In_e_s2;
destruct s2 as [ l2 wr2]; simpl; intro; subst l2.
rewrite list_app_length; rewrite plus_comm; simpl; rewrite plus_comm;
rewrite <- list_app_length; apply le_n_S.
assert (wr1' := without_red_remove e nil le wr1); simpl in wr1'.
assert (wr2' := without_red_remove e l2' l2'' wr2).
assert (H' : subset (mk_set le wr1') (mk_set (l2' ++ l2'') wr2')).
unfold subset; simpl; intros x in_x.
assert (x_diff_e : x <> e).
intro x_eq_e; subst x;
(* Hack pour dejouer un bug de coq : destruct (In_dec eq_elt_dec e le). *)
generalize wr1; simpl; case (In_dec eq_elt_dec e le); intros; contradiction.
generalize (H x); simpl; intro H';
generalize (H' (or_intror _ in_x)); clear H'; intro H';
generalize (in_app_or _ _ _ H'); clear H'; intros [ H' | [e_eq_x | H']];
unfold mem; simpl; apply in_or_app.
left; trivial.
absurd (x = e); trivial; apply sym_eq; trivial.
right; trivial.
generalize (IHle wr1' _ H'); unfold cardinal; simpl; trivial.
Qed.

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.
assert (H : forall acc l1 l2, length (remove_not_common acc l1 l2) =
                       length acc + length (remove_not_common nil l1 l2)).
intros acc l1 l2; generalize acc l1; clear acc l1;
induction l2 as [ | e2 l2]; intros acc l1; trivial.
simpl; destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
rewrite (IHl2 (e2 :: acc) l1); rewrite (IHl2 (e2 :: nil) l1);
simpl; apply sym_eq; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
apply IHl2.

assert (H' : forall acc l1 l2 e, ~In e l1 -> ~ In e l2 ->
                       remove_not_common acc (e :: l1) l2 =
                       remove_not_common acc l1 l2).
intros acc l1 l2; generalize acc l1; clear acc l1; induction l2 as [ | e2 l2].
simpl; intros acc l1 e e_not_in_l1 _;
destruct (In_dec eq_elt_dec e l1) as [ e_in_l1 | _ ]; trivial.
intros acc l1 e e_not_in_l1 e_not_in_e2l2; simpl;
destruct (eq_elt_dec e e2) as [e_eq_e2 | e_diff_e2];
destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
apply IHl2; trivial; intro; apply e_not_in_e2l2; right; trivial.
subst e; absurd (In e2 (e2 :: l2)); trivial; left; trivial.
apply IHl2; trivial; intro; apply e_not_in_e2l2; right; trivial.
apply IHl2; trivial; intro; apply e_not_in_e2l2; right; trivial.

intros [l1 wr1] [l2 wr2]; unfold cardinal; simpl; generalize l1 wr1; clear l1 wr1;
induction l2 as [ | e2 l2];
intros l1 wr1; trivial;
simpl; destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | e2_not_in_l1 ].
rewrite H; simpl;
rewrite plus_comm; simpl; rewrite plus_comm; rewrite IHl2; trivial.
apply (without_red_remove e2 nil l2); trivial.
assert (wr1' : without_red (e2 :: l1)).
simpl; destruct (In_dec eq_elt_dec e2 l1) as [ e2_in_l1 | _ ]; trivial.
absurd (In e2 l1); trivial.
assert (wr2' := without_red_remove e2 nil l2 wr2); simpl in wr2'.
assert (H'' := IHl2 wr2' _ wr1').
rewrite H' in H''; trivial.
rewrite H''; apply sym_eq; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
simpl in wr2; destruct (In_dec eq_elt_dec e2 l2); trivial; contradiction.
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.
intros s1 [l2 wr2]; generalize s1; clear s1.
assert (forall l2', l2' = l2 -> length l2' = length l2).
intros; subst; trivial.
generalize (length l2) H; clear H; intros n H; generalize (H _ (refl_equal _)) wr2;
generalize l2; clear l2 wr2 H; induction n;
destruct l2 as [ | e2 l2].
contradiction.
intro; discriminate.
intro; discriminate.
intros L wr2 s1 e s1_in_e2_l2 e_not_in_s1 [e_eq_e2 | e_in_l2].

assert (wr2' := without_red_remove e2 nil l2 wr2); simpl in wr2'.
injection L; clear L; intro L; generalize (IHn _ L wr2'); clear IHn; intro IHn; subst e.
assert (subset s1 (mk_set l2 wr2')).
intros e e_in_s1; destruct (s1_in_e2_l2 e e_in_s1) as [e_eq_e2 | e_in_l2]; trivial.
absurd (mem e2 s1); subst; trivial.
apply le_lt_trans with (cardinal (mk_set l2 wr2')).
apply cardinal_subset; trivial.
unfold cardinal; simpl; apply lt_n_Sn.
generalize (split_list_app_cons eq_elt_dec _ _ e_in_l2).
destruct (split_list eq_elt_dec l2 e) as [l2' l2'']; clear e_in_l2.
intro; subst l2; assert (wr2' := without_red_remove e (e2 :: l2') l2'' wr2).

assert (L' : length (e2 :: l2' ++ l2'') = n).
simpl in L; injection L; clear L;
rewrite list_app_length; rewrite plus_comm; simpl; rewrite plus_comm;
rewrite <- list_app_length; trivial.
generalize (IHn _ L' wr2'); clear IHn; intro IHn.
assert (subset s1 (mk_set _ wr2')).
intros e' e'_in_s1; destruct (s1_in_e2_l2 e' e'_in_s1) as [e'_eq_e2 | e'_in_l2].
subst; left; trivial.
destruct (in_app_or _ _ _ e'_in_l2) as [e'_in_l2' | e'_in_e_l2''].
simpl; right; apply in_or_app; left; trivial.
destruct e'_in_e_l2'' as [e'_eq_e | e'_in_l2''].
subst e'; absurd (mem e s1); trivial.
simpl; right; apply in_or_app; right; trivial.
apply le_lt_trans with (cardinal (mk_set _ wr2')).
apply cardinal_subset; trivial.
unfold cardinal; simpl; apply lt_n_S.
do 2 rewrite list_app_length; apply plus_lt_compat_l; simpl; apply lt_n_Sn.
Qed.

Lemma eq_set_list_permut_support :
  forall s1 s2,  eq_set s1 s2 -> LP.list_permut s1.(support) s2.(support).
Proof.
intros [l1 wr1]; induction l1 as [ | e1 l1].
intros [[ | e2 l2] wr2].
intros _; simpl; apply LP.list_permut_refl.
intro H; assert (H' := cardinal_eq_set H); discriminate.
intros [l2 wr2] H;
assert (e1_in_l2 := proj1 (H e1) (or_introl _ (refl_equal _))).
generalize (split_list_app_cons eq_elt_dec _ _ e1_in_l2).
simpl; destruct (split_list eq_elt_dec l2 e1) as [l2' l2'']; clear e1_in_l2.
intro; subst l2; assert (wr2' := without_red_remove e1 l2' l2'' wr2).
apply LP.list_permut_add_cons_inside.
assert (wr1' := without_red_remove e1 nil l1 wr1); simpl in wr1'.
apply (IHl1 wr1' (mk_set _ wr2')).
intro e; split; [intro e_in_l1 | intro e_in_l2'_l2''].
assert (e_in_l2'_e1_l2'' := (proj1 (H e)) (or_intror _ e_in_l1)).
destruct (in_app_or _ _ _ e_in_l2'_e1_l2'') as [e_in_l2' | [e_eq_e1 | e_in_l2'']].
unfold mem; simpl; apply in_or_app; left; trivial.
subst e; generalize wr1; simpl; destruct (eq_elt_dec e1 e1) as [ _ | e1_diff_e1];
[idtac | absurd (e1 = e1); trivial].
destruct (In_dec eq_elt_dec e1 l1) as [ _ | e1_not_in_l1].
contradiction.
absurd (In e1 l1); trivial.
unfold mem; simpl; apply in_or_app; right; trivial.

assert (e_in_l2'_e1_l2'' : In e (l2' ++ e1 :: l2'')).
destruct (in_app_or _ _ _ e_in_l2'_l2'') as [e_in_l2' | e_in_l2''].
apply in_or_app; left; trivial.
apply in_or_app; right; right; trivial.
generalize ((proj2 (H e)) e_in_l2'_e1_l2''); intros [e_eq_e1 | e_in_l1]; [idtac | trivial].
assert False.
subst; unfold mem in e_in_l2'_l2''; simpl in e_in_l2'_l2''.
clear e_in_l2'_e1_l2'' H wr1 wr2' wr1' IHl1 l1;
generalize l2'' wr2 e_in_l2'_l2''; clear l2'' wr2 e_in_l2'_l2'';
induction l2' as [ | e2 l2'].
simpl; intro l2'';
destruct (In_dec eq_elt_dec e l2'') as [e_in_l2'' | e_not_in_l2'']; trivial;
intros; absurd (In e l2''); subst; trivial.
intros l2'' wr2 e_in_e2_l2'_l2'';
destruct (in_app_or _ _ _ e_in_e2_l2'_l2'') as [[e_eq_e2 | e_in_l2'] | e_in_l2''].
subst; generalize wr2; simpl;
destruct (In_dec eq_elt_dec e (l2' ++ e :: l2'')) as [ _ | e_not_in_l2'_e_l2''];
trivial.
absurd (In e (l2' ++ e :: l2'')); trivial; apply in_or_app; right; left; trivial.
apply (IHl2' l2'').
apply (without_red_remove e2 nil (l2' ++ e :: l2'') wr2).
apply in_or_app; left; trivial.
apply (IHl2' l2'').
apply (without_red_remove e2 nil (l2' ++ e :: l2'') wr2).
apply in_or_app; right; trivial.
contradiction.
Qed.

Lemma without_red_permut :
 forall l1 l2, without_red l1 -> LP.list_permut l1 l2 -> without_red l2.
Proof.
intro l1; induction l1 as [ | e1 l1].
intros l2 _ P; rewrite (LP.list_permut_nil (LP.list_permut_sym P)); simpl; trivial.
intros l2 wr1 P; assert (e1_in_l2 : In e1 l2).
apply LP.in_permut_in with (e1 :: l1); trivial; left; trivial.
generalize (split_list_app_cons eq_elt_dec _ _ e1_in_l2).
simpl; destruct (split_list eq_elt_dec l2 e1) as [l2' l2'']; clear e1_in_l2.
intro; subst; apply without_red_add.
apply IHl1.
apply (without_red_remove e1 nil l1); trivial.
apply LP.list_permut_remove_hd with e1; trivial.
intro H; simpl in wr1; destruct (In_dec eq_elt_dec e1 l1) as [_ | e1_not_in_l1];
[contradiction | idtac].
apply e1_not_in_l1; apply LP.in_permut_in with (l2' ++ l2''); trivial.
apply LP.list_permut_sym;
apply LP.list_permut_remove_hd with e1; trivial.
Qed.

(*

Lemma without_red_nil : without_red nil.
Proof.
simpl; trivial.
Qed.

Lemma without_red_rec : forall e l, ~In e l -> without_red l -> without_red (e :: l).
Proof.
intros e l not_in_e_l IHl; simpl;
destruct (In_dec eq_elt_dec e l) as [ in_e_l | _]; trivial;
absurd (In e l); trivial.
Qed.

Fixpoint make_set (l : list elt) : t :=

  match l with
  | nil => mk_set nil without_red_nil
  | e :: le =>
       match (In_dec eq_elt_dec e le) with
       | left _ => make_set le
       | right prf =>
           let le_as_set :=
Proof.
intro l.
induction l.
*)
End Make.


From Coq Require Import ssreflect ssrbool ssrfun.

Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

Definition beq_string x y :=
  if string_dec x y then true else false.

Check string_dec.

Lemma beq_stringP {x y} :
  reflect (x = y) (beq_string x y).
Proof.
  case E: (beq_string x y).
  - constructor.
    rewrite /beq_string in E.
    (* {s1 = s2} + {s1 <> s2}  *)
    (*     ^            ^      *)
    (* left H_beq  right H_beq *)
    case S: (string_dec x y)=> [H_beq | H_beq].
    + exact: H_beq.
    + rewrite S in E.
      rewrite /is_left in E.
      discriminate.
  - constructor.
    rewrite /beq_string in E.
    case S: (string_dec x y)=> [H_beq | H_beq].
    + rewrite S in E.
      rewrite /is_left in E.
      discriminate.
    + exact: H_beq.

  Restart.

  case E: (beq_string x y); constructor;
    case S: (string_dec x y) => [hP | hP] //;
      rewrite /beq_string S /is_left in E; discriminate.
Defined.

Theorem beq_string_refl :
  forall s, true = beq_string s s.
Proof.
  move=> s.
  case E: (beq_string s s)=> //.
  move /beq_stringP in E.
  by [].

  Restart.

  move=> s. case E: (beq_string s s)=> //.
  by move /beq_stringP in E.
Qed.

Theorem beq_string_true_iff :
  forall x y : string,
    beq_string x y = true <-> x = y.
Proof.
  split.
  - move /beq_stringP.
    apply.
  - move=> H.
    rewrite H.
    rewrite -beq_string_refl.
    done.

  Restart.

  split.
  - by move /beq_stringP.
  - by move=> ->; rewrite -beq_string_refl.
Qed.

Theorem beq_string_false_iff :
  forall x y : string,
    beq_string x y = false <-> x <> y.
Proof.
  move=> x y.
  rewrite -beq_string_true_iff.
  rewrite not_true_iff_false.
  done.
Qed.

Theorem false_beq_string :
  forall x y : string,
    x <> y -> beq_string x y = false.
Proof.
  move=> x y.
  rewrite beq_string_false_iff.
  apply.
Qed.

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

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

Definition t_update {A : Type} (m : total_map A) (k : string) (v : A) :=
  fun k' => if beq_string k k' then v else m k'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true) "bar" true.

Compute (examplemap "foo").
Compute (examplemap "bar").
Compute (examplemap "baz").

Notation "[< v >]" := (t_empty v) (at level 30).
Notation "st [< k ~~>> v >]" := (t_update st k v) (at level 21, left associativity).

Print examplemap.

Lemma t_update_eq :
  forall A (m : total_map A) k v,
    m [<k ~~>> v>] k = v.
Proof.
  move=> A m k v.
  rewrite /t_update.
  rewrite -beq_string_refl.
  done.
Qed.

Lemma t_update_neq :
  forall (A : Type) v k1 k2 (m : total_map A),
    k1 <> k2 -> m [<k1 ~~>> v>] k2 = m k2.
Proof.
  move=> A v k1 k2 m.
  move=> /beq_stringP.
  rewrite /t_update.
  (* negbTE b : ~~ b -> b = false. *)
  move/negbTE.
  move=>->.
  done.
Qed.

Lemma t_update_shadow :
  forall A (m : total_map A) v1 v2 k,
    m [<k ~~>> v1>] [<k ~~>> v2>] = m [<k ~~>> v2>].
Proof.
  move=> A m v1 v2 k.
  apply: functional_extensionality=> k'.
  rewrite /t_update.
  case: beq_stringP.
  move=> H_eq_k.
  done.
  move=> H_neq_k.
  done.

  Restart.

  move=> ? ? ? ? x1. apply: functional_extensionality => x2.
  by rewrite /t_update; case: beq_stringP.
Qed.

(* TODO *)


(** * Definition of binary relations, auxiliary results *)
Set Implicit Arguments.

Ltac cgen  H := generalize H; clear H.
Ltac celim H := elim H; clear H.

(** A binary relation is a predicate over pairs of processes *)
Definition relation2(X Y: Type) := X -> Y -> Prop.
Definition relation (X: Type) := relation2 X X.
Definition set(X: Type) := X -> Prop.

Section Definitions.

  Variables X Y Z: Type.
  (** Inclusion *)
  Definition incl: relation (relation2 X Y) := fun R1 R2 => forall x y, R1 x y -> R2 x y.
  (** Extensional equality *)
  Definition eeq: relation (relation2 X Y) := fun R1 R2 => incl R1 R2 /\ incl R2 R1.

  Variable R: relation X.
  Definition reflexive     := forall x, R x x.
  Definition transitive    := forall y x z, R x y -> R y z -> R x z.
  Definition symmetric     := forall x y, R x y -> R y x.
  Definition antisymmetric := forall x y, R x y -> R y x -> x=y.

End Definitions.
Hint Unfold incl.

Section Operators.

  Section O.
    Variables X Y Z: Type.
    Variable Rxy:  relation2 X Y.
    Variable Rxy': relation2 X Y.
    Variable Ryz:  relation2 Y Z.

    (* begin hide *)
    Definition eta2: relation2 X Y := fun x y => Rxy x y.
    (* end hide *)

    (** Transposition, composition, union, union `such that' *)
    Definition trans:  relation2 Y X := fun y x => Rxy x y.
    Definition comp:   relation2 X Z := fun x z => exists2 y, Rxy x y & Ryz y z.
    Definition union2: relation2 X Y := fun x y => Rxy x y \/ Rxy' x y.
    Definition union (I: Type) R: relation2 X Y := fun x y => exists i: I, R i x y.
    Definition union_st (P: set (relation2 X Y)) := fun x y => exists2 R, P R & R x y.

  End O.

  Variable X: Type.
  Variable R: relation X.

  (** Reflexive, transitive closure *)
  Inductive star: relation X :=
    | star_refl: forall x, star x x
    | S_star: forall y x z, R x y -> star y z -> star x z.

  (** Transitive closure *)
  Definition plus: relation X := comp R star.

End Operators.
Hint Unfold trans.
Hint Immediate star_refl.

Section Eeq1.

  Variables I X Y Z: Type.
  Variable R' R1': relation2 X Y.
  Variable S': relation2 Y Z.
  Variable R  R1: relation2 X Y.
  Variable S : relation2 Y Z.
  Variables T' T: relation X.
  Variables F' F: I -> relation2 X Y.

  Lemma trans_incl: incl R R' -> incl (trans R) (trans R').
  Proof. auto. Qed.

  Lemma trans_eeq: eeq R R' -> eeq (trans R) (trans R').
  Proof. unfold eeq; intuition. Qed.

  Lemma comp_incl: incl R R' -> incl S S' -> incl (comp R S) (comp R' S').
  Proof.
    unfold eeq, comp, incl; intuition.
    destruct H1 as [ t ]; exists t; auto.
  Qed.

  Lemma comp_eeq: eeq R R' -> eeq S S' -> eeq (comp R S) (comp R' S').
  Proof.
    unfold eeq, comp, incl; intuition;
    destruct H0 as [ t ]; exists t; auto.
  Qed.

  Lemma union_incl: (forall i, incl (F i) (F' i)) -> incl (union F) (union F').
  Proof.
    unfold eeq, union, incl; intuition.
    destruct H0 as [ i ]; exists i; auto.
  Qed.

  Lemma union_eeq: (forall i, eeq (F i) (F' i)) -> eeq (union F) (union F').
  Proof.
    unfold eeq, union, incl; intuition;
    destruct H0 as [ i ]; destruct (H i); exists i; auto.
  Qed.

  Lemma union2_incl: incl R R' -> incl R1 R1' -> incl (union2 R R1) (union2 R' R1').
  Proof.
    unfold incl, union2; intuition.
  Qed.

  Lemma union2_eeq: eeq R R' -> eeq R1 R1' -> eeq (union2 R R1) (union2 R' R1').
  Proof.
    unfold eeq, union2, incl; intuition.
  Qed.

  Lemma star_incl: incl T T' -> incl (star T) (star T').
  Proof.
    intros H x y XY; induction XY as [ x | w x y XW WY IH ]; auto;
      apply S_star with w; auto.
  Qed.

  Lemma star_eeq: eeq T T' -> eeq (star T) (star T').
  Proof.
    intro H; destruct H as [ H1 H2 ]; split;
      intros x y XY; induction XY as [ x | w x y XW WY IH ]; auto;
	apply S_star with w; auto.
  Qed.

  Lemma plus_incl: incl T T' -> incl (plus T) (plus T').
  Proof.
    intros H x y XY; destruct XY as [ w XW WY ]; exists w; auto.
    apply (star_incl H); assumption.
  Qed.

  Lemma plus_eeq: eeq T T' -> eeq (plus T) (plus T').
  Proof.
    intro H; elim H; intros H1 H2; split;
      intros x y XY; destruct XY as [ w XW WY ]; exists w; auto.
    apply (proj1 (star_eeq H)); assumption.
    apply (proj2 (star_eeq H)); assumption.
  Qed.

End Eeq1.
Hint Resolve trans_incl.
Hint Resolve comp_incl.
Hint Resolve union_incl.
Hint Resolve star_incl.
Hint Resolve plus_incl.
Hint Resolve trans_eeq.
Hint Resolve comp_eeq.
Hint Resolve union_eeq.
Hint Resolve star_eeq.
Hint Resolve plus_eeq.

Section InclEeq.

  Variables X Y: Type.
  Variables S R T: relation2 X Y.

  Lemma incl_refl: incl R R.
  Proof fun x y H => H.

  Lemma incl_trans: incl R S -> incl S T -> incl R T.
  Proof. unfold incl; auto. Qed.

  Lemma eeq_refl: eeq R R.
  Proof. intros; split; apply incl_refl. Qed.

  Lemma eeq_trans: eeq R S -> eeq S T -> eeq R T.
  Proof. unfold eeq, incl; split; intuition. Qed.

  Lemma eeq_sym: eeq R S -> eeq S R.
  Proof. unfold eeq, incl; split; intuition. Qed.

End InclEeq.
Hint Immediate incl_refl.
Hint Immediate eeq_refl.
Hint Resolve eeq_sym.

Section star.

  Variable X: Type.
  Variable R: relation X.

  Lemma star1: forall x y, R x y -> star R x y.
  Proof.
    intros x y xRy; eapply S_star; [ apply xRy | apply star_refl ].
  Qed.

  Lemma star_S: forall x y z, star R x y -> R y z -> star R x z.
  Proof.
    intros x y z XY YZ; induction XY.
    apply star1; assumption.
    apply S_star with y; intuition.
  Qed.

  Lemma star_trans: forall x y z, star R x y -> star R y z -> star R x z.
  Proof.
    intros x y z xy; induction xy; intuition.
    apply S_star with y; assumption.
  Qed.

  Lemma plus_star: forall x y, plus R x y -> star R x y.
  Proof.
    intros x y XY; elim XY; intros w XW WY.
    apply S_star with w; intuition.
  Qed.

  Lemma plus_star_plus: forall y x z, plus R x y -> star R y z -> plus R x z.
  Proof.
    intros y x z XY YZ; elim XY; intros w XW WY.
    exists w; intuition.
    apply star_trans with y; assumption.
  Qed.

  Lemma star_plus_plus: forall y x z, star R x y -> plus R y z -> plus R x z.
  Proof.
    induction 1 as [ x | w x y XW WY IH ]; intros YZ.
    assumption.
    exists w; intuition.
    apply plus_star; assumption.
  Qed.

  Lemma plus_trans: forall y x z, plus R x y -> plus R y z -> plus R x z.
  Proof.
    intros y x z XY YZ; apply plus_star_plus with y; try apply plus_star; assumption.
  Qed.

  Lemma plus1: forall x y, R x y -> plus R x y.
  Proof.
    intros x y XY; exists y; intuition.
  Qed.

  Lemma plus_S: forall y x z, star R x y -> R y z -> plus R x z.
  Proof.
    intros y x z XY YZ; apply star_plus_plus with y; try apply plus1; assumption.
  Qed.

  Lemma S_plus: forall y x z, R x y -> star R y z -> plus R x z.
  Proof.
    intros y x z XY YZ; exists y; assumption.
  Qed.

End star.
Hint Resolve star1.
Hint Resolve plus1.
Hint Resolve plus_star.

Ltac destar H w :=
  match type of H with
    star _ ?x ?y => destruct H as [ x | w x y _H1 _H2 ];
      [ idtac | generalize (S_plus _ _H1 _H2); clear _H1 _H2; intro H ]
    | _ => fail "not a star hypothesis"
  end.

Section Plus_WF.
  Variable X: Set.
  Variable R: relation X.
  Hypothesis Rwf: well_founded (trans R).

  Lemma Acc_clos_trans : forall x, Acc (trans R) x -> Acc (trans (plus R)) x.
  Proof.
    induction 1 as [z _ Hz].
    apply Acc_intro.
    intros y Hy.
    elim Hy; intros w Hzw Hwy; clear Hy.
    generalize (Hz _ Hzw); clear Hz Hzw; intro Hw.
    destruct Hwy; intuition.
    apply Acc_inv with x; auto.
    exists y; intuition.
  Qed.
  Hint Resolve Acc_clos_trans.

  Theorem plus_wf: well_founded (trans (plus R)).
  Proof.
    intro; auto.
  Qed.
End Plus_WF.

Section Eeq2.

  Variables I X Y Z: Type.
  Variables R R': relation2 X Y.
  Variable  S: relation2 Y Z.
  Variable  T: relation X.
  Variable  F: I -> relation2 X Y.

  Lemma inv_inv: eeq (trans (trans T)) T.
  Proof.
    intros; unfold trans, eeq, incl; intuition.
  Qed.

  Lemma inv_comp: eeq (trans (comp R S)) (comp (trans S) (trans R)).
  Proof.
    intros; unfold comp, trans, eeq, incl; intuition;
    destruct H as [ t ]; exists t; auto.
  Qed.

  Lemma inv_union: eeq (trans (union F)) (union (fun i => trans (F i))).
  Proof.
    intros; unfold union, trans, eeq, incl; intuition.
  Qed.

  Lemma inv_star: eeq (trans (star T)) (star (trans T)).
  Proof.
    split.
    unfold incl; induction 1; auto; apply star_S with y; auto.
    unfold incl, trans; induction 1; auto; apply star_S with y; auto.
  Qed.

  Lemma inv_plus: eeq (trans (plus T)) (plus (trans T)).
  Proof.
    split.

    unfold trans; intros x y YX; destruct YX as [ w YW WX ].
    cgen YW; cgen y.
    induction WX as [ w | t w x WT TX IH ]; intros y YW.
    apply plus1; apply YW.
    elim IH with w; auto.
    intros t' T'Y WT'.
    exists t'; intuition.
    apply star_S with w; auto.

    unfold trans; intros x y XY; destruct XY as [ w XW WY ].
    cgen XW; cgen x.
    induction WY as [ w | t w y WT TY IH ]; intros x XW.
    apply plus1; apply XW.
    elim IH with w; auto.
    intros t' T'Y WT'.
    exists t'; intuition.
    apply star_S with w; auto.
  Qed.

  Lemma inv_union2: eeq (trans (union2 R R')) (union2 (trans R) (trans R')).
  Proof.
    split; (intros x y H; celim H; intro H; [ left | right ]; auto).
  Qed.

  Lemma comp_assoc: forall W: Type, forall U: relation2 Z W,
    eeq (comp (comp R S) U) (comp R (comp S U)).
  Proof.
    intros W U; split; intros x y H; destruct H as [ w H1 H2 ];
    [ destruct H1 as [ t ] | destruct H2 as [ t ] ];
    exists t; auto; exists w; auto.
  Qed.

  Lemma comp_star_star: eeq (comp (star T) (star T)) (star T).
  Proof.
    split; intros x y H.
    destruct H as [ w ]; apply star_trans with w; assumption.
    exists x; auto.
  Qed.

  Lemma comp_plus_star: eeq (comp (plus T) (star T)) (plus T).
  Proof.
    split; intros x y H; destruct H as [ w ].
    apply plus_star_plus with w; assumption.
    exists w; auto.
  Qed.

  Lemma comp_star_plus: eeq (comp (star T) (plus T)) (plus T).
  Proof.
    split; intros x y H; destruct H as [ w ].
    apply star_plus_plus with w; assumption.
    exists x; auto; apply S_plus with w; assumption.
  Qed.

End Eeq2.
Hint Immediate inv_inv.
Hint Immediate inv_comp.
Hint Immediate inv_union.
Hint Immediate inv_star.
Hint Immediate inv_plus.
Hint Immediate comp_assoc.
Hint Immediate comp_star_star.
Hint Immediate comp_plus_star.
Hint Immediate comp_star_plus.


(* First set of exercises from CPDT *)
(* Dhruv Makwana *)
(* PS. I miss Vim *)

Require Import Basics Bool Arith List Cpdt.CpdtTactics.

Module Q1.
  (* Q1: ternary truth with commutative `and` and `or` functions. *)
  Inductive truth : Set :=
  | Yes
  | No
  | Maybe.

  Definition not (v1 : truth) : truth :=
    match v1 with
    | Yes => No
    | No => Yes
    | Maybe => Maybe
    end.

  Definition and (v1 v2 : truth) : truth :=
    match v1, v2 with
    | Yes, Yes => Yes
    | No, _ | _, No => No
    | Maybe, _ | _, Maybe => Maybe
    end.

  Definition or (v1 v2 : truth) : truth :=
    match v1, v2 with
    | No, No => No
    | Yes, _ | _, Yes => Yes
    | Maybe, _ | _, Maybe => Maybe
    end.

  Theorem comm_and : forall v1 v2 : truth, and v1 v2 = and v2 v1.
    induction v1, v2; crush.
  Qed.

  Theorem comm_or : forall v1 v2 : truth, or v1 v2 = or v2 v1.
    induction v1, v2; crush.
  Qed.

End Q1.

Module Q2.
  (* Q2: Constant time concatenation lists. *)
  Section slist.
    Variable T : Set.

    Inductive slist : Set :=
    | Empty : slist
    | Sing : T -> slist
    | Concat : slist -> slist -> slist.

    Fixpoint flatten (xs : slist) : list T :=
      match xs with
      | Empty => nil
      | Sing x => cons x nil
      | Concat ys zs => flatten ys ++ flatten zs
      end.

    (* This seems too simple, maybe I'm misusnderstanding the question *)
    Theorem flatten_dist_concat : forall ls1 ls2 : slist,
        flatten (Concat ls1 ls2) = flatten ls1 ++ flatten ls2.
      reflexivity.
    Qed.

  End slist.

End Q2.

Module Q3.
  (* Q3: Add variables to the language of Chapter 2 *)
  Inductive binop : Set :=
  | Plus
  | Times.

  Inductive exp : Set :=
  | Const : nat -> exp
  | Binop : binop -> exp -> exp -> exp
  | Var : nat -> exp.

  Definition binopDenote (b : binop) : nat -> nat -> nat :=
    match b with
    | Plus => plus
    | Times => mult
    end.

  Definition var : Set := nat.

  Fixpoint expDenote (e : exp) (env : var -> nat) : nat :=
    match e with
    | Const n => n
    | Var n => env n
    | Binop b e1 e2 => (binopDenote b) (expDenote e1 env) (expDenote e2 env)
    end.

  Fixpoint foldCont (e : exp) : exp :=
    match e with
    | Const _ | Var _ => e
    | Binop b e1 e2 =>
      match foldCont e1, foldCont e2 with
      | Const n1, Const n2 => Const ((binopDenote b) n1 n2)
      | e1', e2' => Binop b e1 e2
      end
    end.

  (* I'll admit, this seems a bit magical, but it does make sense as well. *)
  Theorem foldCont_preserves_expDenote :
    forall (e : exp) (env : var -> nat), expDenote e env = expDenote (foldCont e) env.
    induction e; crush.
    induction foldCont, foldCont; crush.
  Qed.

End Q3.

Module Q4.
  (* Q4: Mutually inductive types instead of dependent ones. *)

  (* Binary operations *)
  (* nat -> nat -> nat *)
  Inductive nat_binop : Set :=
  | NPlus
  | NTimes.

  (* nat -> nat -> bool (to keep things simple) *)
  Inductive bool_binop : Set :=
  | BEqn
  | Blt.

  (* Semantics of binary operations *)
  Definition nat_binop_den (nb : nat_binop) : nat -> nat -> nat :=
    match nb with
    | NPlus => plus
    | NTimes => mult
    end.

  Definition bool_binop_den (bb : bool_binop) : nat -> nat -> bool :=
    match bb with
    | BEqn => beq_nat
    | Blt => leb
    end.

  (* Expressions *)
  Inductive nat_exp : Set :=
  | NConst : nat -> nat_exp
  | NVar : nat -> nat_exp
  | NBinop : nat_binop -> nat_exp -> nat_exp -> nat_exp
  | NIf : bool_exp -> nat_exp -> nat_exp -> nat_exp

  with bool_exp : Set :=
       | BConst : bool -> bool_exp
       | BBinop : bool_binop -> nat_exp -> nat_exp -> bool_exp.

  Definition var : Set := nat.
  (* Semantics of expressions *)
  Fixpoint nat_exp_den (e : nat_exp) (env : var -> nat) : nat :=
    match e with
    | NConst n => n
    | NVar n => env n
    | NBinop bn n1 n2 => (nat_binop_den bn) (nat_exp_den n1 env) (nat_exp_den n2 env)
    | NIf b n1 n2 => nat_exp_den (if bool_exp_den b env then n1 else n2) env
    end

  with bool_exp_den (e : bool_exp) (env : var -> nat) : bool :=
         match e with
         | BConst b => b
         | BBinop bb n1 n2 => (bool_binop_den bb) (nat_exp_den n1 env) (nat_exp_den n2 env)
         end.

  (* Constant-folding *)
  Fixpoint nat_constFold (e : nat_exp) : nat_exp :=
    match e with
    | NConst _ | NVar _ => e
    | NBinop nb e1 e2 =>
      match nat_constFold e1, nat_constFold e2 with
      | NConst n1, NConst n2 => NConst (nat_binop_den nb n1 n2)
      | e1', e2' => NBinop nb e1' e2'
      end
    | NIf cond e1 e2 =>
      match bool_constFold cond with
      | BConst b => if b then nat_constFold e1 else nat_constFold e2
      | BBinop bb n1 n2 as cond => NIf cond (nat_constFold e1) (nat_constFold e2)
      end
    end

  with bool_constFold (e : bool_exp) : bool_exp :=
         match e with
         | BConst _ => e
         | BBinop bb n1 n2 =>
           match nat_constFold n1, nat_constFold n2 with
           | NConst n1', NConst n2' => BConst (bool_binop_den bb n1' n2')
           | n1', n2' => BBinop bb n1' n2'
           end
         end.

  Scheme nat_exp_mut := Induction for nat_exp Sort Prop
  with bool_exp_mut := Induction for bool_exp Sort Prop.

  (* Probably not the best proof-script style. However, I don't know how to improve it (yet). *)
  Theorem nat_constFold_preserves_nat_exp_den :
    forall (e : nat_exp) (env : var -> nat),
      nat_exp_den e env = nat_exp_den (nat_constFold e) env.

    apply (nat_exp_mut
             (fun (e : nat_exp) => forall (env : var -> nat),
                  nat_exp_den e env = nat_exp_den (nat_constFold e) env)
             (fun (e : bool_exp) => forall (env : var -> nat),
                  bool_exp_den e env = bool_exp_den (bool_constFold e) env)); crush.

    induction nat_constFold, nat_constFold; crush.
    induction bool_constFold; crush.
    destruct b0; crush.
    induction bool_binop_den; crush.
    induction nat_constFold, nat_constFold; crush.

  Qed.

End Q4.

Module Q5.

  (* Q5: Mutually inductive even and odd natural numbers. *)
  Inductive even_nat : Set :=
  | Z : even_nat
  | ES : odd_nat -> even_nat

  with odd_nat : Set :=
       | OS : even_nat -> odd_nat.

  Scheme even_nat_mut := Induction for even_nat Sort Prop
  with odd_nat_mut := Induction for odd_nat Sort Prop.

  Fixpoint even_add (n1 n2 : even_nat) : even_nat :=
    match n1 with
    | Z => n2
    | ES n1' =>  ES (odd_add n1' n2)
    end

  with odd_add (n1 : odd_nat) (n2 : even_nat) : odd_nat :=
     match n1 with
     | OS n1' => OS (even_add n1' n2)
     end.

  (* Although this one was easy in the end, it took a *loong* time to get here.
   * My only advice is to
   *     (a) REALLY PAY ATTENTION TO THE GOAL: mirror the form exactly for the first case
   *     (b) Think and try to get as close a form for the mutual cases. *)
  Theorem even_add_comm : forall (n1 n2 : even_nat), even_add n1 n2 = even_add n2 n1.

    apply (even_nat_mut
             (fun n1 : even_nat => forall n2 : even_nat,
                  even_add n1 n2 = even_add n2 n1)
             (fun n1 : odd_nat => forall n2 : even_nat,
                  ES (odd_add n1 n2) = even_add n2 (ES n1))
          ); crush.

    apply (even_nat_mut
             (fun n1 : even_nat => n1 = even_add n1 Z)
             (fun n1 : odd_nat => n1 = odd_add n1 Z)
          ); crush.

    apply (even_nat_mut
             (fun n1 : even_nat => forall n2 : even_nat,
                  ES (OS (even_add n1 n2)) = even_add n1 (ES (OS n2)))
             (fun n1 : odd_nat => forall n2 : even_nat,
                  OS (ES (odd_add n1 n2)) = odd_add n1 (ES (OS n2)))
          ); crush.
  Qed.

End Q5.

Module Q6.

  (* Reflexive (inductive) types *)
  Inductive nat_tree : Set :=
  | Lf : nat -> nat_tree
  | Br : (nat -> nat_tree) -> nat_tree.

  Fixpoint increment (tr : nat_tree) : nat_tree :=
    match tr with
    | Lf n => Lf (S n)
    | Br f => Br (fun n => increment (f n))
    end.

  Fixpoint leapfrog (i : nat) (nt : nat_tree) : nat :=
    match nt with
    | Lf n => n
    | Br f => leapfrog (S i) (f i)
    end.

  Theorem increment_leapfrog : forall (nt : nat_tree) (i : nat),
      S (leapfrog i nt) = leapfrog i (increment nt).

    induction nt; crush.

  Qed.

End Q6.

Module Q7.

  (* Nested inductive types *)
  Inductive btree (T : Set) : Set :=
  | Lf : T -> btree T
  | Br : btree T -> btree T -> btree T.

  Arguments Lf {T} _.
  Arguments Br {T} _ _.

  Inductive trexp : Set :=
  | Base : nat -> trexp
  | BTr  : btree trexp -> trexp.

  Fixpoint sum (tr : trexp) : nat :=
    match tr with
    | Base n => n
    | BTr tr' =>
      (fix sum_btree (btr : btree trexp) : nat :=
         match btr with
         | Lf t => sum t
         | Br t1 t2 => sum_btree t1 + sum_btree t2
         end) tr'
    end.

  Fixpoint increment (tr : trexp) : trexp :=
    match tr with
    | Base n => Base (S n)
    | BTr tr' =>
      BTr ((fix incr_btree (btr : btree trexp) : btree trexp :=
              match btr with
              | Lf t => Lf (increment t)
              | Br t1 t2 => Br (incr_btree t1) (incr_btree t2)
              end) tr')
    end.

  Section trexp_ind'.

    (* Computing a "type" = theorem for an arbitrary btree *)
    Fixpoint All {T : Set} (P : T -> Prop) (btr : btree T) : Prop :=
      match btr with
      | Lf lf => P lf
      | Br t1 t2 => All P t1 /\ All P t2
      end.

    (* I did look at the solutions, but this does makes sense now.
     * The tricky bit for me was the term/type "distinction" of proof/value vs theorem/type and
     * understanding the meaning of the syntax. *)

    (* Synonyms for "global" implicit arguments *)
    Variable P : trexp -> Prop.
    Hypothesis Base_case : forall (n : nat), P (Base n).
    Hypothesis BTr_case : forall (btr : btree trexp), All P btr -> P (BTr btr).

    Fixpoint trexp_ind' (tr : trexp) : P tr :=
      match tr with
      | Base n => Base_case n
      | BTr tr' =>
        (* Constructing a proof of the type of the theorem we assumed earlier *)
        BTr_case tr' ((fix btree_ind (btr : btree trexp) : All P btr :=
                     match btr with
                     | Lf lf => trexp_ind' lf
                     | Br t1 t2 => conj (btree_ind t1) (btree_ind t2)
                     end) tr')
      end.
  End trexp_ind'.

  Theorem incr_larger_total : forall (tr : trexp), sum (increment tr) >= sum tr.
    induction tr using trexp_ind'; crush.
    induction btr; crush.
  Qed.

End Q7.

Module Q8.

  Inductive nat_btree : Set :=
  | Lf : nat_btree
  | Br : nat_btree -> nat -> nat_btree -> nat_btree.

  Definition toProp (b : nat_btree) :=
    match b with
    | Lf => False
    | Br _ _ _ => True
    end.

  Theorem leaf_not_node : forall (n : nat) (t1 t2 : nat_btree), Lf <> Br t1 n t2.

    red.
    intros.
    change (toProp Lf).
    rewrite H.
    simpl.
    trivial.

  Qed.

  (* Originally I wrote this without a default parameter (returned O for Lf) *)
  Definition node_val (def : nat) (tr : nat_btree) : nat :=
    match tr with
    | Lf => def
    | Br _ n _ => n
    end.

  Theorem eq_nodes_nums : forall (def nl nr : nat) (tll tlr trl trr : nat_btree),
      Br tll nl tlr = Br trl nr trr -> nl = nr.

    intros.
    change (node_val def (Br tll nl tlr) = node_val def (Br trl nr trr)).
    rewrite H.
    reflexivity.

  Qed.

End Q8.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.N2Z.
Require Import Crypto.Util.ZUtil.Pow.
Require Import Crypto.Util.ZUtil.Pow2.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Testbit.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.NUtil.WithoutReferenceToZ.
Local Open Scope Z_scope.

Module Z.
  Lemma lor_range : forall x y n, 0 <= x < 2 ^ n -> 0 <= y < 2 ^ n ->
                                  0 <= Z.lor x y < 2 ^ n.
  Proof.
    intros x y n H H0; assert (0 <= n) by auto with zarith lia.
    repeat match goal with
           | |- _ => progress intros
           | |- _ => rewrite Z.lor_spec
           | |- _ => rewrite Z.testbit_eqb by auto with zarith lia
           | |- _ => rewrite !Z.div_small by (split; try lia; eapply Z.lt_le_trans;
                             [ intuition eassumption | apply Z.pow_le_mono_r; lia])
           | |- _ => split
           | |- _ => apply Z.testbit_false_bound
           | |- _ => solve [auto with zarith]
           | |- _ => solve [apply Z.lor_nonneg; intuition auto]
           end.
  Qed.
  Hint Resolve lor_range : zarith.

  Lemma lor_shiftl_bounds : forall x y n m,
      (0 <= n)%Z -> (0 <= m)%Z ->
      (0 <= x < 2 ^ m)%Z ->
      (0 <= y < 2 ^ n)%Z ->
      (0 <= Z.lor y (Z.shiftl x n) < 2 ^ (n + m))%Z.
  Proof.
    intros x y n m H H0 H1 H2.
    apply Z.lor_range.
    { split; try lia.
      apply Z.lt_le_trans with (m := (2 ^ n)%Z); try lia.
      apply Z.pow_le_mono_r; lia. }
    { rewrite Z.shiftl_mul_pow2 by lia.
      rewrite Z.pow_add_r by lia.
      split; Z.zero_bounds.
      rewrite Z.mul_comm.
      apply Z.mul_lt_mono_pos_l; lia. }
  Qed.

  Lemma land_upper_bound_l : forall a b, (0 <= a) -> (0 <= b) ->
    Z.land a b <= a.
  Proof.
    intros a b H H0.
    destruct a, b; try solve [exfalso; auto]; try solve [cbv; congruence].
    cbv [Z.land].
    rewrite <-N2Z.inj_pos, <-N2Z.inj_le.
    auto using N.Pos_land_upper_bound_l.
  Qed.

  Lemma land_upper_bound_r : forall a b, (0 <= a) -> (0 <= b) ->
    Z.land a b <= b.
  Proof.
    intros.
    rewrite Z.land_comm.
    auto using Z.land_upper_bound_l.
  Qed.

  Section ZInequalities.
    Lemma land_le' : forall x y, (0 <= x)%Z -> (Z.land x y <= x)%Z.
    Proof.
      intros x y H; apply Z.ldiff_le; [assumption|].
      rewrite Z.ldiff_land, Z.land_comm, Z.land_assoc.
      rewrite <- Z.land_0_l with (a := y); f_equal.
      rewrite Z.land_comm, Z.land_lnot_diag.
      reflexivity.
    Qed.

    Lemma lor_lower : forall x y, (0 <= x -> 0 <= y)%Z -> (x <= Z.lor x y)%Z.
    Proof.
      intros x y H.
      destruct (Z_lt_le_dec x 0).
      { Z.replace_all_neg_with_pos.
        replace (-x) with (Z.lnot (x - 1)) by (cbv [Z.pred Z.lnot]; lia).
        rewrite <- (Z.lnot_involutive y).
        rewrite <- Z.lnot_land.
        cbv [Z.lnot].
        rewrite <- !Z.sub_1_r.
        Z.peel_le.
        apply land_le'; lia. }
      { apply Z.ldiff_le; [apply Z.lor_nonneg; auto|].
        rewrite Z.ldiff_land.
        apply Z.bits_inj_iff'; intros k Hpos; apply Z.le_ge in Hpos.
        rewrite Z.testbit_0_l, Z.land_spec, Z.lnot_spec, Z.lor_spec;
          [|apply Z.ge_le; assumption].
        induction (Z.testbit x k), (Z.testbit y k); cbv; reflexivity. }
    Qed.

    Lemma land_le : forall x y, (0 <= y -> 0 <= x)%Z -> (Z.land x y <= x)%Z.
    Proof.
      intros x y H.
      destruct (Z_lt_le_dec y 0), (Z_lt_le_dec x 0); auto using land_le' with lia.
      Z.replace_all_neg_with_pos.
      replace (-x) with (Z.lnot (x - 1)) by (cbv [Z.pred Z.lnot]; lia).
      replace (-y) with (Z.lnot (y - 1)) by (cbv [Z.pred Z.lnot]; lia).
      rewrite <- Z.lnot_lor.
      cbv [Z.lnot].
      rewrite <- !Z.sub_1_r.
      Z.peel_le.
      apply lor_lower; lia.
    Qed.

    Lemma land_le_neg_l_lower :
      forall x y, (x < 0)%Z -> (0 <= y) -> (x <= Z.land x y)%Z.
    Proof.
      intros x y ? ?. destruct x, y; cbn [Z.land]; lia.
    Qed.

    Lemma land_le_neg_l_upper :
      forall x y, (x < 0)%Z -> (0 <= y) -> (Z.land x y <= y)%Z.
    Proof.
      intros; rewrite Z.land_comm. auto using land_le'.
    Qed.

    Lemma land_neg_l_range :
      forall x y, x < 0 -> 0 <= y -> x <= Z.land x y <= y.
    Proof.
      auto using land_le_neg_l_lower, land_le_neg_l_upper.
    Qed.
    Lemma land_neg_r_range :
      forall x y, 0 <= x -> y < 0 -> y <= Z.land x y <= x.
    Proof.
      intros; rewrite Z.land_comm. auto using land_neg_l_range.
    Qed.

    Lemma lor_neg_lower :
      forall x y, x < 0 -> y < 0 -> (Z.max x y <= Z.lor x y)%Z.
    Proof.
      intros x y ? ?. destruct x, y; cbn [Z.lor]; try lia.
      apply Z.opp_le_mono.
      repeat first [ rewrite N.pos_pred_spec
                   | rewrite N.succ_pos_spec
                   | rewrite Z.opp_max_distr
                   | rewrite Pos2Z.opp_neg
                   | rewrite <-!positive_N_Z
                   | rewrite N.succ_pos_spec ].
      rewrite !N2Z.inj_succ, !N2Z.inj_land,
      !N2Z.inj_pred, !N2Z.inj_pos by lia.
      match goal with
      | |- context [Z.land ?a ?b] =>
        let Hab := fresh in
        let Hba := fresh in
        pose proof (land_le a b ltac:(lia)) as Hab;
          pose proof (land_le b a ltac:(lia)) as Hba;
          rewrite Z.land_comm in Hba
      end.
      lia.
    Qed.

    Lemma land_neg_lower' :
      forall x y n, x < 0 -> y < 0 ->
                    - 2 ^ n <= x ->
                    - 2 ^ n <= y ->
                    - 2 ^ n <= Z.land x y.
    Proof.
      intros x y n. intros.
      destruct x, y; cbn [Z.land]; try lia; [ ].
      apply Z.opp_le_mono.
      repeat first [ rewrite N.pos_pred_spec
                   | rewrite N.succ_pos_spec
                   | rewrite Z.opp_max_distr
                   | rewrite Pos2Z.opp_neg
                   | rewrite <-!positive_N_Z
                   | rewrite N.succ_pos_spec
                   | rewrite Z.opp_involutive
                   | rewrite Z.opp_succ ].
      rewrite !N2Z.inj_succ, !N2Z.inj_lor,
      !N2Z.inj_pred, !N2Z.inj_pos by lia.
      match goal with
      | |- context [Z.lor ?a ?b] =>
        pose proof (lor_range a b n ltac:(lia) ltac:(lia))
      end.
      lia.
    Qed.

    Lemma land_neg_lower :
      forall x y,
        x < 0 -> y < 0 ->
        - 2 ^ (Z.max (Z.log2_up (-x)) (Z.log2_up (-y))) <= Z.land x y.
    Proof.
      intros x y. intros.
      pose proof (Z.log2_log2_up_spec (-x) ltac:(lia)).
      pose proof (Z.log2_log2_up_spec (-y) ltac:(lia)).
      pose proof (Z.pow_le_mono 2 (Z.log2_up (-x))
                                2 (Z.log2_up (-y)) ltac:(lia)).
      pose proof (Z.pow_le_mono 2 (Z.log2_up (-y))
                                2 (Z.log2_up (-x)) ltac:(lia)).
      apply land_neg_lower'; auto; [ | ].
      { apply Z.opp_le_mono.
        rewrite Z.opp_involutive.
        apply Z.max_case_strong; lia. }
      { apply Z.opp_le_mono.
        rewrite Z.opp_involutive.
        apply Z.max_case_strong; lia. }
    Qed.

    Lemma lor_le : forall x y z,
        (0 <= x)%Z
        -> (x <= y)%Z
        -> (y <= z)%Z
        -> (Z.lor x y <= (2 ^ Z.log2_up (z+1)) - 1)%Z.
    Proof.
      intros x y z H H0 H1; apply Z.ldiff_le.

      - apply Z.le_add_le_sub_r.
        replace 1%Z with (2 ^ 0)%Z by (cbv; reflexivity).
        rewrite Z.add_0_l.
        apply Z.pow_le_mono_r; [cbv; reflexivity|].
        apply Z.log2_up_nonneg.

      - destruct (Z_lt_dec 0 z).

        + assert (forall a, a - 1 = Z.pred a)%Z as HP by (intro; lia);
            rewrite HP, <- Z.ones_equiv; clear HP.
          apply Z.ldiff_ones_r_low; [apply Z.lor_nonneg; split; lia|].
          rewrite Z.log2_up_eqn, Z.log2_lor; try lia.
          apply Z.lt_succ_r.
          apply Z.max_case_strong; intros; apply Z.log2_le_mono; lia.

        + replace z with 0%Z by lia.
          replace y with 0%Z by lia.
          replace x with 0%Z by lia.
          cbv; reflexivity.
    Qed.

    Local Ltac solve_pow2 :=
      repeat match goal with
             | [|- _ /\ _] => split
             | [|- (0 < 2 ^ _)%Z] => apply Z.pow2_gt_0
             | [|- (0 <= 2 ^ _)%Z] => apply Z.pow2_ge_0
             | [|- (2 ^ _ <= 2 ^ _)%Z] => apply Z.pow_le_mono_r
             | [|- (_ <= _)%Z] => lia
             | [|- (_ < _)%Z] => lia
             end.

    Lemma pow2_mod_range : forall a n m,
        (0 <= n) ->
        (n <= m) ->
        (0 <= Z.pow2_mod a n < 2 ^ m).
    Proof.
      intros; unfold Z.pow2_mod.
      rewrite Z.land_ones; [|assumption].
      split; [apply Z.mod_pos_bound, Z.pow2_gt_0; assumption|].
      eapply Z.lt_le_trans; [apply Z.mod_pos_bound, Z.pow2_gt_0; assumption|].
      apply Z.pow_le_mono; [|assumption].
      split; simpl; lia.
    Qed.

    Lemma shiftr_range : forall a n m,
        (0 <= n)%Z ->
        (0 <= m)%Z ->
        (0 <= a < 2 ^ (n + m))%Z ->
        (0 <= Z.shiftr a n < 2 ^ m)%Z.
    Proof.
      intros a n m H0 H1 H2; destruct H2.
      split; [apply Z.shiftr_nonneg; assumption|].
      rewrite Z.shiftr_div_pow2; [|assumption].
      apply Z.div_lt_upper_bound; [apply Z.pow2_gt_0; assumption|].
      eapply Z.lt_le_trans; [eassumption|apply Z.eq_le_incl].
      apply Z.pow_add_r; lia.
    Qed.

    Lemma shiftr_le_mono: forall a b c d,
        (0 <= a)%Z
        -> (0 <= d)%Z
        -> (a <= c)%Z
        -> (d <= b)%Z
        -> (Z.shiftr a b <= Z.shiftr c d)%Z.
    Proof.
      intros.
      repeat rewrite Z.shiftr_div_pow2; [|lia|lia].
      etransitivity; [apply Z.div_le_compat_l | apply Z.div_le_mono]; solve_pow2.
    Qed.

    Lemma shiftl_le_mono: forall a b c d,
        (0 <= a)%Z
        -> (0 <= b)%Z
        -> (a <= c)%Z
        -> (b <= d)%Z
        -> (Z.shiftl a b <= Z.shiftl c d)%Z.
    Proof.
      intros.
      repeat rewrite Z.shiftl_mul_pow2; [|lia|lia].
      etransitivity; [apply Z.mul_le_mono_nonneg_l|apply Z.mul_le_mono_nonneg_r]; solve_pow2.
    Qed.
  End ZInequalities.

  Lemma lor_bounds x y : 0 <= x -> 0 <= y
                         -> Z.max x y <= Z.lor x y <= 2^Z.log2_up (Z.max x y + 1) - 1.
  Proof.
    apply Z.max_case_strong; intros; split;
      try solve [ eauto using lor_lower, Z.le_trans, lor_le with lia
                | rewrite Z.lor_comm; eauto using lor_lower, Z.le_trans, lor_le with lia ].
  Qed.
  Lemma lor_bounds_lower x y : 0 <= x -> 0 <= y
                               -> Z.max x y <= Z.lor x y.
  Proof. intros; apply lor_bounds; assumption. Qed.
  Lemma lor_bounds_upper x y : Z.lor x y <= 2^Z.log2_up (Z.max x y + 1) - 1.
  Proof.
    pose proof (proj2 (Z.lor_neg x y)).
    destruct (Z_lt_le_dec x 0), (Z_lt_le_dec y 0);
      try solve [ intros; apply lor_bounds; assumption ];
      transitivity (2^0-1);
      try apply Z.sub_le_mono_r, Z.pow_le_mono_r, Z.log2_up_nonneg;
      simpl; lia.
  Qed.
  Lemma lor_bounds_gen_lower x y l : 0 <= x -> 0 <= y -> l <= Z.max x y
                                     -> l <= Z.lor x y.
  Proof.
    intros; etransitivity;
      solve [ apply lor_bounds; auto
            | eauto ].
  Qed.
  Lemma lor_bounds_gen_upper x y u : x <= u -> y <= u
                                     -> Z.lor x y <= 2^Z.log2_up (u + 1) - 1.
  Proof.
    intros; etransitivity; [ apply lor_bounds_upper | ].
    apply Z.sub_le_mono_r, Z.pow_le_mono_r, Z.log2_up_le_mono, Z.max_case_strong;
      lia.
  Qed.
  Lemma lor_bounds_gen x y l u : 0 <= x -> 0 <= y -> l <= Z.max x y -> x <= u -> y <= u
                                 -> l <= Z.lor x y <= 2^Z.log2_up (u + 1) - 1.
  Proof. auto using lor_bounds_gen_lower, lor_bounds_gen_upper. Qed.

  Lemma shiftl_le_Proper2 y
    : Proper (Z.le ==> Z.le) (fun x => Z.shiftl x y).
  Proof.
    unfold Basics.flip in *.
    pose proof (Zle_cases 0 y) as Hx.
    intros x x' H.
    pose proof (Zle_cases 0 x) as Hy.
    pose proof (Zle_cases 0 x') as Hy'.
    destruct (0 <=? y), (0 <=? x), (0 <=? x');
      autorewrite with Zshift_to_pow;
      Z.replace_all_neg_with_pos;
      autorewrite with pull_Zopp;
      rewrite ?Z.div_opp_l_complete;
      repeat destruct (Z_zerop _);
      autorewrite with zsimplify_const pull_Zopp;
      auto with zarith;
      repeat match goal with
             | [ |- context[-?x - ?y] ]
               => replace (-x - y) with (-(x + y)) by lia
             | _ => rewrite <- Z.opp_le_mono
             | _ => rewrite <- Z.add_le_mono_r
             | _ => solve [ auto with zarith ]
             | [ |- ?x <= ?y + 1 ]
               => cut (x <= y); [ lia | solve [ auto with zarith ] ]
             | [ |- -_ <= _ ]
               => solve [ transitivity (-0); auto with zarith ]
             end.
    { repeat match goal with H : context[_ mod _] |- _ => revert H end;
        Z.div_mod_to_quot_rem_in_goal; nia. }
  Qed.

  Lemma shiftl_le_Proper1 x
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
    : Proper (R (0 <=? x) ==> Z.le) (Z.shiftl x).
  Proof.
    unfold Basics.flip in *.
    pose proof (Zle_cases 0 x) as Hx.
    intros y y' H.
    pose proof (Zle_cases 0 y) as Hy.
    pose proof (Zle_cases 0 y') as Hy'.
    destruct (0 <=? x), (0 <=? y), (0 <=? y'); subst R; cbv beta iota in *;
      autorewrite with Zshift_to_pow;
      Z.replace_all_neg_with_pos;
      autorewrite with pull_Zopp;
      rewrite ?Z.div_opp_l_complete;
      repeat destruct (Z_zerop _);
      autorewrite with zsimplify_const pull_Zopp;
      auto with zarith;
      repeat match goal with
             | [ |- context[-?x - ?y] ]
               => replace (-x - y) with (-(x + y)) by lia
             | _ => rewrite <- Z.opp_le_mono
             | _ => rewrite <- Z.add_le_mono_r
             | _ => solve [ auto with zarith ]
             | [ |- ?x <= ?y + 1 ]
               => cut (x <= y); [ lia | solve [ auto with zarith ] ]
             | [ |- context[2^?x] ]
               => lazymatch goal with
                  | [ H : 1 < 2^x |- _ ] => fail
                  | [ H : 0 < 2^x |- _ ] => fail
                  | [ H : 0 <= 2^x |- _ ] => fail
                  | _ => first [ assert (1 < 2^x) by auto with zarith
                               | assert (0 < 2^x) by auto with zarith
                               | assert (0 <= 2^x) by auto with zarith ]
                  end
             | [ H : ?x <= ?y |- _ ]
               => is_var x; is_var y;
                    lazymatch goal with
                    | [ H : 2^x <= 2^y |- _ ] => fail
                    | [ H : 2^x < 2^y |- _ ] => fail
                    | _ => assert (2^x <= 2^y) by auto with zarith
                    end
             | [ H : ?x <= ?y, H' : ?f ?x = ?k, H'' : ?f ?y <> ?k |- _ ]
               => let Hn := fresh in
                  assert (Hn : x <> y) by congruence;
                    assert (x < y) by lia; clear H Hn
             | [ H : ?x <= ?y, H' : ?f ?x <> ?k, H'' : ?f ?y = ?k |- _ ]
               => let Hn := fresh in
                  assert (Hn : x <> y) by congruence;
                    assert (x < y) by lia; clear H Hn
             | _ => solve [ repeat match goal with H : context[_ mod _] |- _ => revert H end;
                            Z.div_mod_to_quot_rem_in_goal; subst;
                            lazymatch goal with
                            | [ |- _ <= (?a * ?q + ?r) * ?q' ]
                              => transitivity (q * (a * q') + r * q');
                                 [ assert (0 < a * q') by nia; nia
                                 | nia ]
                            end ]
             end.
    { replace y' with (y + (y' - y)) by lia.
      rewrite Z.pow_add_r, <- Zdiv_Zdiv by auto with zarith.
      assert (y < y') by (assert (y <> y') by congruence; lia).
      assert (1 < 2^(y'-y)) by auto with zarith.
      assert (0 < x / 2^y)
        by (repeat match goal with H : context[_ mod _] |- _ => revert H end;
            Z.div_mod_to_quot_rem_in_goal; nia).
      assert (2^y <= x)
        by (repeat match goal with H : context[_ / _] |- _ => revert H end;
            Z.div_mod_to_quot_rem_in_goal; nia).
      match goal with
      | [ |- ?x + 1 <= ?y ] => cut (x < y); [ lia | ]
      end.
      auto with zarith. }
  Qed.

  Lemma shiftr_le_Proper2 y
    : Proper (Z.le ==> Z.le) (fun x => Z.shiftr x y).
  Proof. apply shiftl_le_Proper2. Qed.

  Lemma shiftr_le_Proper1 x
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
    : Proper (R (x <? 0) ==> Z.le) (Z.shiftr x).
  Proof.
    subst R; intros y y' H'; unfold Z.shiftr; apply shiftl_le_Proper1.
    unfold Basics.flip in *.
    pose proof (Zle_cases 0 x).
    pose proof (Zlt_cases x 0).
    destruct (0 <=? x), (x <? 0); try lia.
  Qed.
End Z.


Lemma L1 : forall (A B:Prop), A \/ B -> ~A -> B.
Proof.
    intros A B [H|H] H'.
    - apply H' in H. contradiction.
    - assumption.
Qed.


Require Export prosa.model.task.concept.
Require Export prosa.util.seqset.
Require Export prosa.util.rel.
From mathcomp Require Import div.

(** Throughout this file, we assume ideal uniprocessor schedules. *)
Require prosa.model.processor.ideal.

(** * TDMA Scheduling *)

(** The TDMA scheduling policy is based on two properties.
    (1) Each task has a fixed, reserved time slot for execution;
    (2) These time slots are ordered in sequence to form a TDMA cycle, which
        repeats along the timeline.
    An example of TDMA schedule is illustrated in the following.
<<
    _______________________________
    | s1 |  s2  |s3| s1 |  s2  |s3|...
    --------------------------------------------->
    0                                            t
>> *)

(** ** Task Parameter for TDMA Scheduling *)

(** We define the TDMA policy as follows.*)
Section TDMAPolicy.

  Variable Task: eqType.
  (** With each task, we associate the duration of the corresponding TDMA slot. *)
  Definition TDMA_slot := Task -> duration.

  (** Moreover, within each TDMA cycle, task slots are ordered according to
      some relation (i.e, [slot_order slot1 slot2] means that [slot1] comes
      before [slot2] in a TDMA cycle). *)
  Definition TDMA_slot_order := rel Task.

End TDMAPolicy.

(** We introduce slots and the slot order as task parameters. *)
Class TDMAPolicy (T : TaskType) :=
  {
    task_time_slot : TDMA_slot T;
    slot_order : TDMA_slot_order T
  }.

(** ** TDMA Policy Validity *)

(** First, we define the properties of a valid TDMA policy. *)
Section ValidTDMAPolicy.

  Context {Task : eqType}.

  (** Consider any task set ts... *)
  Variable ts : {set Task}.

  (** ...and a TDMA policy. *)
  Context `{TDMAPolicy Task}.

  (** Time slot order must be transitive... *)
  Definition transitive_slot_order := transitive slot_order.

  (** ..., totally ordered over the task set... *)
  Definition total_slot_order :=
    total_over_list slot_order ts.

  (** ... and antisymmetric over task set. *)
  Definition antisymmetric_slot_order :=
    antisymmetric_over_list slot_order ts.

  (** A valid time slot must be positive *)
  Definition valid_time_slot :=
    forall tsk, tsk \in ts -> task_time_slot tsk > 0.

  Definition valid_TDMAPolicy :=
    transitive_slot_order /\ total_slot_order /\ antisymmetric_slot_order /\ valid_time_slot.

End ValidTDMAPolicy.

 (** ** TDMA Cycles, Sots, and Offsets *)

(** In this section, we define key TDMA concepts. *)
Section TDMADefinitions.

  Context {Task : eqType}.

  (** Consider any task set ts... *)
  Variable ts : {set Task}.

  (** ...and a TDMA policy. *)
  Context `{TDMAPolicy Task}.

  (** We define the TDMA cycle as the sum of all the tasks' time slots *)
  Definition TDMA_cycle:=
    \sum_(tsk <- ts) task_time_slot tsk.

  (** We define the function returning the slot offset for each task: i.e., the
      distance between the start of the TDMA cycle and the start of the task
      time slot. *)
  Definition task_slot_offset (tsk : Task) :=
    \sum_(prev_task <- ts | slot_order prev_task tsk && (prev_task != tsk)) task_time_slot prev_task.

  (** The following function tests whether a task is in its time slot at
      instant [t]. *)
  Definition task_in_time_slot (tsk : Task) (t:instant):=
    ((t + TDMA_cycle - (task_slot_offset tsk)%% TDMA_cycle) %% TDMA_cycle)
    < (task_time_slot tsk).

End TDMADefinitions.

(** ** TDMA Schedule Validity *)

Section TDMASchedule.

  Context {Task : TaskType} {Job : JobType}.

  Context `{JobArrival Job} `{JobCost Job} `{JobReady Job (option Job)} `{JobTask Job Task}.

  (** Consider any job arrival sequence... *)
  Variable arr_seq : arrival_sequence Job.

  (** ..., any uniprocessor ideal schedule ... *)
  Variable sched : schedule (ideal.processor_state Job).

  (** ... and any sporadic task set. *)
  Variable ts: {set Task}.

  Context `{TDMAPolicy Task}.

  (** In order to characterize a TDMA policy, we first define whether a job is executing its TDMA slot at time [t]. *)
  Definition job_in_time_slot (job:Job) (t:instant):=
    task_in_time_slot ts (job_task job) t.

  (** We say that a TDMA policy is respected by the schedule iff
       1. when a job is scheduled at time [t], then the corresponding task
          is also in its own time slot... *)
  Definition sched_implies_in_slot j t:=
    scheduled_at sched j t -> job_in_time_slot j t.

  (** 2. when a job is backlogged at time [t], the corresponding task
          isn't in its own time slot or another previous job of the same task is scheduled *)
  Definition backlogged_implies_not_in_slot_or_other_job_sched j t:=
    backlogged sched j t ->
    ~ job_in_time_slot j t \/
    exists j_other, arrives_in arr_seq j_other/\
                    job_arrival j_other < job_arrival j/\
                    job_task j = job_task j_other/\
                    scheduled_at sched j_other t.

  Definition respects_TDMA_policy:=
    forall (j:Job) (t:instant),
      arrives_in arr_seq j ->
      sched_implies_in_slot j t /\
      backlogged_implies_not_in_slot_or_other_job_sched j t.
End TDMASchedule.


Theorem Modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  intros P Q H1 H2.
  apply H2.
  assumption.
Qed.


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

(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Export Arith_base.
Require Import BinPos BinInt BinNat Zcompare Zorder.
Require Import Decidable Peano_dec Min Max Compare_dec.

Local Open Scope Z_scope.

Definition neq (x y:nat) := x <> y.

(************************************************)
(** Properties of the injection from nat into Z *)

Lemma Zpos_P_of_succ_nat : forall n:nat,
 Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n).
Proof.
  intros [|n]. trivial. apply Zpos_succ_morphism.
Qed.

(** Injection and successor *)

Theorem inj_0 : Z_of_nat 0 = 0.
Proof.
  reflexivity.
Qed.

Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n).
Proof.
  exact Zpos_P_of_succ_nat.
Qed.

(** Injection and comparison *)

Theorem inj_compare : forall n m:nat,
 (Z_of_nat n ?= Z_of_nat m) = nat_compare n m.
Proof.
 induction n; destruct m; trivial.
 rewrite 2 inj_S, Zcompare_succ_compat. now simpl.
Qed.

(** Injection and equality. *)

Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m.
Proof.
  intros; subst; trivial.
Qed.

Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m.
Proof.
  intros n m H. apply nat_compare_eq.
  now rewrite <- inj_compare, H, Zcompare_refl.
Qed.

Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
Proof.
  unfold neq, Zne. intros n m H. contradict H. now apply inj_eq_rev.
Qed.

Theorem inj_eq_iff : forall n m:nat, n=m <-> Z_of_nat n = Z_of_nat m.
Proof.
 split; [apply inj_eq | apply inj_eq_rev].
Qed.

(** Injection and order *)

(** Both ways ... *)

Theorem inj_le_iff : forall n m:nat, (n<=m)%nat <-> Z_of_nat n <= Z_of_nat m.
Proof.
 intros. unfold Zle. rewrite inj_compare. apply nat_compare_le.
Qed.

Theorem inj_lt_iff : forall n m:nat, (n<m)%nat <-> Z_of_nat n < Z_of_nat m.
Proof.
 intros. unfold Zlt. rewrite inj_compare. apply nat_compare_lt.
Qed.

Theorem inj_ge_iff : forall n m:nat, (n>=m)%nat <-> Z_of_nat n >= Z_of_nat m.
Proof.
 intros. unfold Zge. rewrite inj_compare. apply nat_compare_ge.
Qed.

Theorem inj_gt_iff : forall n m:nat, (n>m)%nat <-> Z_of_nat n > Z_of_nat m.
Proof.
 intros. unfold Zgt. rewrite inj_compare. apply nat_compare_gt.
Qed.

(** One way ... *)

Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m.
Proof. apply inj_le_iff. Qed.

Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
Proof. apply inj_lt_iff. Qed.

Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m.
Proof. apply inj_ge_iff. Qed.

Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m.
Proof. apply inj_gt_iff. Qed.

(** The other way ... *)

Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat.
Proof. apply inj_le_iff. Qed.

Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat.
Proof. apply inj_lt_iff. Qed.

Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat.
Proof. apply inj_ge_iff. Qed.

Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat.
Proof. apply inj_gt_iff. Qed.

(** Injection and usual operations *)

Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
Proof.
 induction n as [|n IH]; intros [|m]; simpl; trivial.
 rewrite <- plus_n_O; trivial.
 change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)).
 now rewrite inj_S, IH, 2 inj_S, Zplus_succ_l.
Qed.

Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m.
Proof.
 induction n as [|n IH]; intros m; trivial.
 rewrite inj_S, Zmult_succ_l, <- IH, <- inj_plus.
 simpl. now rewrite plus_comm.
Qed.

Theorem inj_minus1 :
  forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m.
Proof.
 intros n m H.
 apply (Zplus_reg_l (Z_of_nat m)); unfold Zminus.
 rewrite Zplus_permute, Zplus_opp_r, <- inj_plus, Zplus_0_r.
 f_equal. symmetry. now apply le_plus_minus.
Qed.

Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
Proof.
 intros. rewrite not_le_minus_0; auto with arith.
Qed.

Theorem inj_minus : forall n m:nat,
 Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m).
Proof.
 intros n m. unfold Zmax.
 destruct (le_lt_dec m n) as [H|H].
 (* m <= n *)
 rewrite inj_minus1; trivial.
 apply inj_le, Zle_minus_le_0 in H. revert H. unfold Zle.
 case Zcompare_spec; intuition.
 (* n < m *)
 rewrite inj_minus2; trivial.
 apply inj_lt, Zlt_gt in H.
 apply (Zplus_gt_compat_r _ _ (- Z_of_nat m)) in H.
 rewrite Zplus_opp_r in H.
 unfold Zminus. rewrite H; auto.
Qed.

Theorem inj_min : forall n m:nat,
  Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m).
Proof.
 intros n m. unfold Zmin. rewrite inj_compare.
 case nat_compare_spec; intros; f_equal; subst; auto with arith.
Qed.

Theorem inj_max : forall n m:nat,
  Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m).
Proof.
 intros n m. unfold Zmax. rewrite inj_compare.
 case nat_compare_spec; intros; f_equal; subst; auto with arith.
Qed.

(** Composition of injections **)

Lemma Z_of_nat_of_P : forall p, Z_of_nat (nat_of_P p) = Zpos p.
Proof.
 intros p. destruct (nat_of_P_is_S p) as (n,H). rewrite H.
 simpl. f_equal. rewrite <- (nat_of_P_of_succ_nat n) in H.
 symmetry. now apply nat_of_P_inj.
Qed.

(** For compatibility *)
Definition Zpos_eq_Z_of_nat_o_nat_of_P p := eq_sym _ _ _ (Z_of_nat_of_P p).

(******************************************************************)
(** Properties of the injection from N into Z *)

Lemma Z_of_nat_of_N : forall n, Z_of_nat (nat_of_N n) = Z_of_N n.
Proof.
  intros [|n]. trivial.
  simpl. apply Z_of_nat_of_P.
Qed.

Lemma Z_of_N_of_nat : forall n, Z_of_N (N_of_nat n) = Z_of_nat n.
Proof.
 now destruct n.
Qed.

Lemma Z_of_N_eq : forall n m, n = m -> Z_of_N n = Z_of_N m.
Proof.
 intros; f_equal; assumption.
Qed.

Lemma Z_of_N_eq_rev : forall n m, Z_of_N n = Z_of_N m -> n = m.
Proof.
 intros [|n] [|m]; simpl; congruence.
Qed.

Lemma Z_of_N_eq_iff : forall n m, n = m <-> Z_of_N n = Z_of_N m.
Proof.
 split; [apply Z_of_N_eq | apply Z_of_N_eq_rev].
Qed.

Lemma Z_of_N_compare : forall n m,
 Zcompare (Z_of_N n) (Z_of_N m) = Ncompare n m.
Proof.
 intros [|n] [|m]; trivial.
Qed.

Lemma Z_of_N_le_iff : forall n m, (n<=m)%N <-> Z_of_N n <= Z_of_N m.
Proof.
 intros. unfold Zle. now rewrite Z_of_N_compare.
Qed.

Lemma Z_of_N_le : forall n m, (n<=m)%N -> Z_of_N n <= Z_of_N m.
Proof.
 apply Z_of_N_le_iff.
Qed.

Lemma Z_of_N_le_rev : forall n m, Z_of_N n <= Z_of_N m -> (n<=m)%N.
Proof.
 apply Z_of_N_le_iff.
Qed.

Lemma Z_of_N_lt_iff : forall n m, (n<m)%N <-> Z_of_N n < Z_of_N m.
Proof.
 intros. unfold Zlt. now rewrite Z_of_N_compare.
Qed.

Lemma Z_of_N_lt : forall n m, (n<m)%N -> Z_of_N n < Z_of_N m.
Proof.
 apply Z_of_N_lt_iff.
Qed.

Lemma Z_of_N_lt_rev : forall n m, Z_of_N n < Z_of_N m -> (n<m)%N.
Proof.
 apply Z_of_N_lt_iff.
Qed.

Lemma Z_of_N_ge_iff : forall n m, (n>=m)%N <-> Z_of_N n >= Z_of_N m.
Proof.
 intros. unfold Zge. now rewrite Z_of_N_compare.
Qed.

Lemma Z_of_N_ge : forall n m, (n>=m)%N -> Z_of_N n >= Z_of_N m.
Proof.
 apply Z_of_N_ge_iff.
Qed.

Lemma Z_of_N_ge_rev : forall n m, Z_of_N n >= Z_of_N m -> (n>=m)%N.
Proof.
 apply Z_of_N_ge_iff.
Qed.

Lemma Z_of_N_gt_iff : forall n m, (n>m)%N <-> Z_of_N n > Z_of_N m.
Proof.
 intros. unfold Zgt. now rewrite Z_of_N_compare.
Qed.

Lemma Z_of_N_gt : forall n m, (n>m)%N -> Z_of_N n > Z_of_N m.
Proof.
 apply Z_of_N_gt_iff.
Qed.

Lemma Z_of_N_gt_rev : forall n m, Z_of_N n > Z_of_N m -> (n>m)%N.
Proof.
 apply Z_of_N_gt_iff.
Qed.

Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p.
Proof.
 reflexivity.
Qed.

Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z.
Proof.
 now destruct z.
Qed.

Lemma Z_of_N_le_0 : forall n, 0 <= Z_of_N n.
Proof.
 now destruct n.
Qed.

Lemma Z_of_N_plus : forall n m, Z_of_N (n+m) = Z_of_N n + Z_of_N m.
Proof.
 now destruct n, m.
Qed.

Lemma Z_of_N_mult : forall n m, Z_of_N (n*m) = Z_of_N n * Z_of_N m.
Proof.
 now destruct n, m.
Qed.

Lemma Z_of_N_minus : forall n m, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m).
Proof.
 intros [|n] [|m]; simpl; trivial.
 case Pcompare_spec; intros H.
 subst. now rewrite Pminus_mask_diag.
 rewrite Pminus_mask_Lt; trivial.
 unfold Pminus.
 destruct (Pminus_mask_Gt n m (ZC2 _ _ H)) as (q & -> & _); trivial.
Qed.

Lemma Z_of_N_succ : forall n, Z_of_N (Nsucc n) = Zsucc (Z_of_N n).
Proof.
 intros [|n]; simpl; trivial. now rewrite Zpos_succ_morphism.
Qed.

Lemma Z_of_N_min : forall n m, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m).
Proof.
 intros. unfold Zmin, Nmin. rewrite Z_of_N_compare. now case Ncompare.
Qed.

Lemma Z_of_N_max : forall n m, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m).
Proof.
 intros. unfold Zmax, Nmax. rewrite Z_of_N_compare.
 case Ncompare_spec; intros; subst; trivial.
Qed.

(** Results about the [Zabs_N] function, converting from Z to N *)

Lemma Zabs_of_N : forall n, Zabs_N (Z_of_N n) = n.
Proof.
 now destruct n.
Qed.

Lemma Zabs_N_succ_abs : forall n,
 Zabs_N (Zsucc (Zabs n)) = Nsucc (Zabs_N n).
Proof.
 intros [ |n|n]; simpl; trivial; now rewrite Pplus_one_succ_r.
Qed.

Lemma Zabs_N_succ : forall n, 0<=n ->
 Zabs_N (Zsucc n) = Nsucc (Zabs_N n).
Proof.
 intros n Hn. rewrite <- Zabs_N_succ_abs. repeat f_equal.
 symmetry; now apply Zabs_eq.
Qed.

Lemma Zabs_N_plus_abs : forall n m,
 Zabs_N (Zabs n + Zabs m) = (Zabs_N n + Zabs_N m)%N.
Proof.
 intros [ |n|n] [ |m|m]; simpl; trivial.
Qed.

Lemma Zabs_N_plus : forall n m, 0<=n -> 0<=m ->
 Zabs_N (n + m) = (Zabs_N n + Zabs_N m)%N.
Proof.
 intros n m Hn Hm.
 rewrite <- Zabs_N_plus_abs; repeat f_equal;
  symmetry; now apply Zabs_eq.
Qed.

Lemma Zabs_N_mult_abs : forall n m,
 Zabs_N (Zabs n * Zabs m) = (Zabs_N n * Zabs_N m)%N.
Proof.
 intros [ |n|n] [ |m|m]; simpl; trivial.
Qed.

Lemma Zabs_N_mult : forall n m, 0<=n -> 0<=m ->
 Zabs_N (n * m) = (Zabs_N n * Zabs_N m)%N.
Proof.
 intros n m Hn Hm.
 rewrite <- Zabs_N_mult_abs; repeat f_equal;
  symmetry; now apply Zabs_eq.
Qed.