(** To do : Is it a clone of ListSet ? *)

(** Evelyne Contejean, LRI *)

(** * Sets built with lists *)

Set Implicit Arguments.

From Coq Require Import List Arith Lia.

From hydras Require Import more_list list_permut.

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 Nat.le_0_l.
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 Nat.add_comm; simpl;
  rewrite Nat.add_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 Nat.add_comm;
simpl; rewrite Nat.add_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 Nat.add_comm; simpl; rewrite Nat.add_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 Nat.add_comm; simpl; rewrite Nat.add_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).
symmetry;apply Nat.add_sub_eq_l.
 rewrite <- H; now rewrite Nat.add_comm.
Qed.

Lemma cardinal_eq_set : forall s1 s2, eq_set s1 s2 -> cardinal s1 = cardinal s2.
Proof.
intros s1 s2 s1_eq_s2; apply Nat.le_antisymm; 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 Nat.le_lt_trans with (cardinal (mk_set l2 wr2')).
apply cardinal_subset; trivial.
unfold cardinal; simpl; apply Nat.lt_succ_diag_r.
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 Nat.add_comm; simpl; rewrite Nat.add_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 Nat.le_lt_trans with (cardinal (mk_set _ wr2')).
apply cardinal_subset; trivial.
unfold cardinal; simpl; apply Nat.succ_lt_mono.
do 2 rewrite list_app_length. simpl.  lia.
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.


(* John Backus's FP programming language, Backus's FP *)
(* プログラム代数 *)
(* Backus's FP Algebra *)

Require Import Setoid.                      (* rewrite H at n *)
Require Import Arith.

Inductive fp : Set :=
(* 組込関数 *)
| Id : fp
| None : fp                                 (* construction の端 *)
| Left : fp
| Right : fp
| Apndl : fp
(* 高階関数 *)
| Composition : fp -> fp -> fp
| Construction : fp -> fp -> fp
| Condition : fp -> fp -> fp -> fp
| Apply_to_all : fp -> fp
| Insert_right : fp -> fp
  .

Implicit Arguments Composition.
Infix "**" := Composition (at level 151, right associativity).
Implicit Arguments Construction.
Infix ":::" := Construction (at level 161, right associativity).
Notation "a ? b ; c" := (Condition a b c) (at level 190).
Implicit Arguments Apply_to_all.
Notation "@" := Apply_to_all (at level 141).
Implicit Arguments Insert_right.
Notation "//" := Insert_right (at level 141).

Variables obj : Set.
Variables cons : obj -> obj -> obj.
Infix "::" := cons (at level 60, right associativity). (* Listはつかえなくなる。 *)
Variables none : obj.
Variables tt : obj.

Inductive exec : obj -> fp -> obj -> Prop := .
(* | execId : forall x : obj, exec x Id x.
   以下の公理をここに書いてしまうこともできる。
   *)

Axiom execId :
  forall x : obj, exec x Id x.

Axiom execLeft :
  forall (x y : obj),
    exec (cons x (cons y none)) Left x.
Axiom execRight :
  forall (x y : obj),
    exec (cons x (cons y none)) Right y.
Axiom execAppend :
  forall (x y : obj),
    exec (x :: y :: none) Apndl (x :: y).
(* 1 :: (2::3::4::none) :: none => 1 :: 2 :: 3 :: 4 :: none *)

Axiom execComp :
  forall (x z : obj) (f g : fp),
    (exists y, exec z g y /\ exec y f x) -> exec z (Composition f g) x.

Axiom execCons0 :
  forall (x : obj),
    exec x None none.
Axiom execCons :
  forall (x y z : obj) (f g : fp),
    (exec z f x /\ exec z g y) -> exec z (Construction f g) (cons x y).

Axiom execCondTrue :
  forall (x y : obj) (p f g : fp),
    (exec x p tt /\ exec x f y) -> exec x (Condition p f g) y.
Axiom execCondFalse :
  forall (x y : obj) (p f g : fp),
    (exec x p none /\ exec x g y) -> exec x (Condition p f g) y.

Axiom execMap0 :
  forall (f : fp),
    exec none (Apply_to_all f) none.
Axiom execMap :
  forall (x y xl yl : obj) (f : fp),
    exec y f x /\ exec yl (Apply_to_all f) xl ->
    exec (cons y yl) (Apply_to_all f) (cons x xl).

Axiom execInst0 :
  forall (x : obj) (f : fp),
    exec (cons x none) f x.
Axiom execInst :
  forall (x z l : obj) (f : fp),
    (exists y, exec (cons x (cons y none)) f z /\ exec l (Insert_right f) y) ->
    exec (cons x l) (Insert_right f) z.

(* 証明の例 *)

Lemma test_Id :
  forall xi xo : obj,
    xi = xo -> exec xi Id xo.
Proof.
  intros.
  rewrite <- H.
  apply execId.
Qed.

Lemma test_cond_comp :
  forall (x y : obj) (p f g : fp),
    (exec x p tt /\ exec x f y) -> exec x (p ? f ** Id ; g) y.
Proof.
  intros.
  apply execCondTrue.
  split.
  apply H.
  apply execComp.
  exists x.
  split.
  apply execId.
  destruct H as [Hp Hf].
  apply Hf.
Qed.

Lemma test_map_Id :
  forall xi xo : obj,
    exec xi Id xo -> exec (xi :: none) (@ Id) (xo :: none).
Proof.
  intros.
  apply execMap.
  split.
  apply H.
  apply execMap0.
Qed.

Lemma test_inst_Left :
  forall x y z : obj,
    exec (x :: y :: z :: none) (// Left) x.
Proof.
  intros.
  apply execInst.
  exists y.
  split.
  apply execLeft.

  apply execInst.
  exists z.
  split.
  apply execLeft.
  apply execInst0.
Qed.

Lemma test_inst_Right :
  forall x y z : obj,
    exec (x :: y :: z :: none) (// Right) z.
Proof.
  intros.
  apply execInst.
  exists z.
  split.
  apply execRight.

  apply execInst.
  exists z.
  split.
  apply execRight.
  apply execInst0.
Qed.

Lemma test_left_append :
  forall x y : obj,
    exec (x :: (y :: none) :: none) (Left ** Apndl) x.
Proof.
  intros.
  apply execComp.
  exists (x :: y :: none).
  split.
  apply execAppend.
  apply execLeft.
Qed.

Lemma test_append0 :                        (* Id ** [Left,Right] = Id *)
  forall x y,
    exec (x :: y :: none) (Id ** (Left ::: Right ::: None)) (x :: y :: none).
Proof.
  intros.
  apply execComp.
  exists (x :: y :: none).
  split.
  apply execCons.
  split.
  apply execLeft.
  apply execCons.
  split.
  apply execRight.
  apply execCons0.
  apply execId.
Qed.

Lemma test_append :                         (* Apndl ** [Left,[Right]] = Id *)
  forall x y,
    exec (x :: y :: none) (Apndl ** (Left ::: (Right ::: None) ::: None)) (x :: y :: none).
Proof.
  intros.
  apply execComp.
  exists (x :: (y :: none) :: none).
  split.
  apply execCons.
  split.
  apply execLeft.
  apply execCons.
  split.
  apply execCons.
  split.
  apply execRight.
  apply execCons0.
  apply execCons0.
  apply execAppend.
Qed.

(*
Lemma test :
  forall f g h,
    (Apndl ** (f ** g ::: @ f ** h ::: None)) =
    (@ f ** Apndl ** (g ::: h ::: None)).
*)

(* END *)


(** Author: Michael A. Warren (maw@mawarren.net) in consultation with Vladimir Voevodsky.*)
(** Date: Spring - Summer 2015.*)
(** Description: Some tactics for natural numbers. *)

(** Tactics for natural numbers.*)
(** by Michael A. Warren, April - June 2015.*)

(** ADD: Disclaimer regarding connection with other tactics files.*)

Require Import
        UniMath.Foundations.NaturalNumbers
        UniMath.Tactics.Utilities
        UniMath.Tactics.Abmonoids_Tactics.

Local Open Scope nat_scope.

(** * Basic definitions and hints. *)

Definition natneqtwist n (p : ¬ (0 = n)) : ¬ (n = 0) :=
  λ f, p (pathsinv0 f).

Definition nat_plus_perm021 :
  ∏ n0 n1 n2,
    n0 + n1 + n2 = n0 + n2 + n1 :=
  λ n0 n1 n2,
    pathscomp0
      (pathscomp0
         (natplusassoc n0 n1 n2)
         (maponpaths (λ z, n0 + z) (natpluscomm n1 n2)))
      (pathsinv0 (natplusassoc n0 n2 n1)).

Definition nat_plus_perm102 :
  ∏ n0 n1 n2,
    n0 + n1 + n2 = n1 + n0 + n2 :=
  λ n0 n1 n2, maponpaths (λ z, z + n2) (natpluscomm n0 n1).

Definition nat_plus_perm120 :
  ∏ n0 n1 n2,
    n0 + n1 + n2 = n2 + n0 + n1 :=
  λ n0 n1 n2,
    pathscomp0 (natpluscomm (n0 + n1) n2) (pathsinv0 (natplusassoc n2 n0 n1)).

Definition nat_plus_perm201 :
  ∏ n0 n1 n2,
    n0 + n1 + n2 = n1 + n2 + n0 :=
  λ n0 n1 n2,
    pathscomp0 (natplusassoc n0 n1 n2) (natpluscomm n0 (n1 + n2)).

Definition nat_plus_perm210 :
  ∏ n0 n1 n2,
    n0 + n1 + n2 = n2 + n1 + n0 :=
  λ n0 n1 n2,
    pathscomp0 (nat_plus_perm102 n0 n1 n2) (nat_plus_perm120 n1 n0 n2).

Definition nat_mult_perm021 :
  ∏ n0 n1 n2,
    n0 * n1 * n2 = n0 * n2 * n1 :=
  λ n0 n1 n2,
    pathscomp0
      (pathscomp0
         (natmultassoc n0 n1 n2)
         (maponpaths (λ z, n0 * z) (natmultcomm n1 n2)))
      (pathsinv0 (natmultassoc n0 n2 n1)).

Definition nat_mult_perm102 :
  ∏ n0 n1 n2,
    n0 * n1 * n2 = n1 * n0 * n2 :=
  λ n0 n1 n2, maponpaths (λ z, z * n2) (natmultcomm n0 n1).

Definition nat_mult_perm120 :
  ∏ n0 n1 n2,
    n0 * n1 * n2 = n2 * n0 * n1 :=
  λ n0 n1 n2,
    pathscomp0 (natmultcomm (n0 * n1) n2) (pathsinv0 (natmultassoc n2 n0 n1)).

Definition nat_mult_perm201 :
  ∏ n0 n1 n2,
    n0 * n1 * n2 = n1 * n2 * n0 :=
  λ n0 n1 n2,
    pathscomp0 (natmultassoc n0 n1 n2) (natmultcomm n0 (n1 * n2)).

Definition nat_mult_perm210 :
  ∏ n0 n1 n2,
    n0 * n1 * n2 = n2 * n1 * n0 :=
  λ n0 n1 n2,
    pathscomp0 (nat_mult_perm102 n0 n1 n2) (nat_mult_perm120 n1 n0 n2).

Definition minus0r : ∏ n, n - 0 = n :=
  λ n, match n with
             | 0 => (idpath _)
             | S _ => (idpath _)
           end.

Definition minusnn0 n : n - n = 0.
Proof.
  induction n as [|n IHn]; [exact (idpath 0) | exact IHn].
Defined.

(** minus0l and Lemma minussn1 n : (S n) - 1 change to n - 0 should be changed in tactics.*)

Definition minusgeh n m : n >= (n - m).
Proof.
  revert m. induction n as [|n IHn]; intros. apply isreflnatgeh.
  destruct m. rewrite minus0r. apply isreflnatgeh.
  apply (istransnatgeh _ n _). apply natgthtogeh. apply natgthsnn.
  apply IHn.
Defined.

(** * Tactics for rearranging subterms of goals and hypotheses.*)

(** ** Tactics for performing ternary permutations of words written in [+] and [*].*)

(** TACTIC: [nat_plus_ternary_perm]

    SUMMARY: [nat_plus_ternary_perm] permutes words of length 3 in [+].

    USAGE: Provided that the current [goal] is of the form [lhs = rhs], [nat_plus_ternary_perm x y z] will permute a subterm of [lhs] so that it now appears in the form [x + y + z].

    EXAMPLE: If the current goal is [x + y + z = y + z + x], then [nat_plus_ternary_perm y z x] will change the goal to [y + z + x = y + z + x].*)
Ltac nat_plus_ternary_perm s t u :=
  match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | context[t + s + u] =>
          rewrite (nat_plus_perm102 t s u); idtac
        | context[t + u + s] =>
          rewrite (nat_plus_perm120 t u s); idtac
        | context[u + s + t] =>
          rewrite (nat_plus_perm201 u s t); idtac
        | context[u + t + s] =>
          rewrite (nat_plus_perm210 u t s); idtac
        | context[s + u + t] =>
          rewrite (nat_plus_perm021 s u t); idtac
        | context[?x + t + s + u] =>
          rewrite (natplusassoc x t s); rewrite (natplusassoc x (t + s) u);
          rewrite (nat_plus_perm102 t s u);
          rewrite <- (natplusassoc x (s + t) u);
          rewrite <- (natplusassoc x s t); idtac
        | context[?x + t + u + s] =>
          rewrite (natplusassoc x t u); rewrite (natplusassoc x (t + u) s);
          rewrite (nat_plus_perm120 t u s);
          rewrite <- (natplusassoc x (s + t) u);
          rewrite <- (natplusassoc x s t); idtac
        | context[?x + u + s + t] =>
          rewrite (natplusassoc x u s); rewrite (natplusassoc x (u + s) t);
          rewrite (nat_plus_perm201 u s t);
          rewrite <- (natplusassoc x (s + t) u);
          rewrite <- (natplusassoc x s t); idtac
        | context[?x + u + t + s] =>
          rewrite (natplusassoc x u t); rewrite (natplusassoc x (u + t) s);
          rewrite (nat_plus_perm210 u t s);
          rewrite <- (natplusassoc x (s + t) u);
          rewrite <- (natplusassoc x s t); idtac
        | context[?x + s + u + t] =>
          rewrite (natplusassoc x s u); rewrite (natplusassoc x (s + u) t);
          rewrite (nat_plus_perm021 s u t);
          rewrite <- (natplusassoc x (s + t) u);
          rewrite <- (natplusassoc x s t); idtac
      end
  end.

(** TACTIC: [nat_mult_ternary_perm]

    SUMMARY: [nat_mult_ternary_perm] permutes words of length 3 in [*].

    USAGE: See [nat_plus_ternary_perm] above.*)
Ltac nat_mult_ternary_perm s t u :=
  match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | context[t * s * u] =>
          rewrite (nat_mult_perm102 t s u); idtac
        | context[t * u * s] =>
          rewrite (nat_mult_perm120 t u s); idtac
        | context[u * s * t] =>
          rewrite (nat_mult_perm201 u s t); idtac
        | context[u * t * s] =>
          rewrite (nat_mult_perm210 u t s); idtac
        | context[s * u * t] =>
          rewrite (nat_mult_perm021 s u t); idtac
        | context[?x * t * s * u] =>
          rewrite (natmultassoc x t s); rewrite (natmultassoc x (t * s) u);
          rewrite (nat_mult_perm102 t s u);
          rewrite <- (natmultassoc x (s * t) u);
          rewrite <- (natmultassoc x s t); idtac
        | context[?x * t * u * s] =>
          rewrite (natmultassoc x t u); rewrite (natmultassoc x (t * u) s);
          rewrite (nat_mult_perm120 t u s);
          rewrite <- (natmultassoc x (s * t) u);
          rewrite <- (natmultassoc x s t); idtac
        | context[?x * u * s * t] =>
          rewrite (natmultassoc x u s); rewrite (natmultassoc x (u * s) t);
          rewrite (nat_mult_perm201 u s t);
          rewrite <- (natmultassoc x (s * t) u);
          rewrite <- (natmultassoc x s t); idtac
        | context[?x * u * t * s] =>
          rewrite (natmultassoc x u t); rewrite (natmultassoc x (u * t) s);
          rewrite (nat_mult_perm210 u t s);
          rewrite <- (natmultassoc x (s * t) u);
          rewrite <- (natmultassoc x s t); idtac
        | context[?x * s * u * t] =>
          rewrite (natmultassoc x s u); rewrite (natmultassoc x (s * u) t);
          rewrite (nat_mult_perm021 s u t);
          rewrite <- (natmultassoc x (s * t) u);
          rewrite <- (natmultassoc x s t); idtac
      end
  end.

(** ** Tactics for grouping pairs of terms appearing in words written in [+] and [*].*)

(** *** Helper tactics (which should not be considered as part of the public interface for these tactics).*)

Ltac nat_plus_not_word s :=
  match s with
    | ?x + ?y => fail 1
    | _ => idtac
  end.

Ltac nat_plus_not_at_front t s :=
  match t with
    | s => fail 1
    | context[s + ?x] => fail 1
    | _ => idtac
  end.

Ltac nat_plus_not_at_back t s :=
  match t with
    | s => fail 1 "A"
    | ?x + s => fail 1 "B"
    | _ => idtac
  end.

Ltac nat_plus_move_to_back s :=
  repeat
    let lhs := get_current_lhs in
    nat_plus_not_at_back lhs s;
      match lhs with
        | s + ?x => rewrite (natpluscomm s x)
        | context[?x + s + ?y] =>
          rewrite (nat_plus_perm021 x s y)
        | context[s + ?x + ?y] =>
          rewrite (nat_plus_perm201 s x y)
      end.

Ltac nat_plus_move_to_back_in H s :=
  repeat
    let lhs := get_current_lhs_in H in
    nat_plus_not_at_back lhs s;
      match lhs with
        | s + ?x => rewrite (natpluscomm s x) in H
        | context[?x + s + ?y] =>
          rewrite (nat_plus_perm021 x s y) in H
        | context[s + ?x + ?y] =>
          rewrite (nat_plus_perm201 s x y) in H
      end.

Ltac nat_plus_move_to_front s :=
  repeat
    let lhs := get_current_lhs in
    nat_plus_not_at_front lhs s;
      match lhs with
        | context[?x + s] =>
          nat_plus_not_word x; rewrite (natpluscomm x s)
        | context[?x + ?y + s] => nat_plus_not_word y;
            rewrite (nat_plus_perm021 x y s)
      end.

Ltac nat_plus_move_to_front_in H s :=
  repeat
    let lhs := get_current_lhs_in H in
    nat_plus_not_at_front lhs s;
      match lhs with
        | context[?x + s] =>
          nat_plus_not_word x; rewrite (natpluscomm x s) in H
        | context[?x + ?y + s] => nat_plus_not_word y;
            rewrite (nat_plus_perm021 x y s) in H
      end.

Ltac nat_plus_move_to_front_goal s :=
  repeat
    let rhs := get_current_rhs in
    nat_plus_not_at_front rhs s;
      match rhs with
        | context[?x + s] =>
          nat_plus_not_word x; rewrite (natpluscomm x s)
        | context[?x + ?y + s] => nat_plus_not_word y;
            rewrite (nat_plus_perm021 x y s)
      end.

Ltac nat_plus_move_to_front_both_in H s :=
  repeat
    let rhs := get_current_rhs_in H in
    nat_plus_not_at_front rhs s;
      match rhs with
        | context[?x + s] =>
          nat_plus_not_word x; rewrite (natpluscomm x s) in H
        | context[?x + ?y + s] => nat_plus_not_word y;
            rewrite (nat_plus_perm021 x y s) in H
      end.

Ltac nat_plus_move_to_back_goal s :=
  repeat
    let rhs := get_current_rhs in
    nat_plus_not_at_back rhs s;
      match rhs with
        | context [s + ?x] => rewrite (natpluscomm s x)
        | context[?x + s + ?y] => nat_plus_not_word y;
            rewrite (nat_plus_perm021 x s y)
        | context[s + ?x + ?y] =>
          nat_plus_not_word x; nat_plus_not_word y;
          rewrite (nat_plus_perm201 s x y)
      end.

Ltac nat_plus_move_to_back_both_in H s :=
  repeat
    let rhs := get_current_rhs_in H in
    nat_plus_not_at_back rhs s;
      match rhs with
        | context [s + ?x] => rewrite (natpluscomm s x)
        | context[?x + s + ?y] => nat_plus_not_word y;
            rewrite (nat_plus_perm021 x s y) in H
        | context[s + ?x + ?y] =>
          nat_plus_not_word x; nat_plus_not_word y;
          rewrite (nat_plus_perm201 s x y) in H
      end.

Ltac nat_mult_not_word s :=
  match s with
    | ?x * ?y => fail 1
    | _ => idtac
  end.

Ltac nat_mult_not_at_front t s :=
  match t with
    | s => fail 1
    | context[s * ?x] => fail 1
    | _ => idtac
  end.

Ltac nat_mult_not_at_back t s :=
  match t with
    | s => fail 1 "A"
    | ?x * s => fail 1 "B"
    | _ => idtac
  end.

Ltac nat_mult_move_to_back s :=
  repeat
    let lhs := get_current_lhs in
    nat_mult_not_at_back lhs s;
      match lhs with
        | s * ?x => rewrite (natmultcomm s x)
        | context[?x * s * ?y] =>
          rewrite (nat_mult_perm021 x s y)
        | context[s * ?x * ?y] =>
          rewrite (nat_mult_perm201 s x y)
      end.

Ltac nat_mult_move_to_back_in H s :=
  repeat
    let lhs := get_current_lhs_in H in
    nat_mult_not_at_back lhs s;
      match lhs with
        | s * ?x => rewrite (natmultcomm s x) in H
        | context[?x * s * ?y] =>
          rewrite (nat_mult_perm021 x s y) in H
        | context[s * ?x * ?y] =>
          rewrite (nat_mult_perm201 s x y) in H
      end.

Ltac nat_mult_move_to_front s :=
  repeat
    let lhs := get_current_lhs in
    nat_mult_not_at_front lhs s;
      match lhs with
        | context[?x * s] =>
          nat_mult_not_word x; rewrite (natmultcomm x s)
        | context[?x * ?y * s] => nat_mult_not_word y;
            rewrite (nat_mult_perm021 x y s)
      end.

Ltac nat_mult_move_to_front_in H s :=
  repeat
    let lhs := get_current_lhs_in H in
    nat_mult_not_at_front lhs s;
      match lhs with
        | context[?x * s] =>
          nat_mult_not_word x; rewrite (natmultcomm x s) in H
        | context[?x * ?y * s] => nat_mult_not_word y;
            rewrite (nat_mult_perm021 x y s) in H
      end.

Ltac nat_mult_move_to_front_goal s :=
  repeat
    let rhs := get_current_rhs in
    nat_mult_not_at_front rhs s;
      match rhs with
        | context[?x * s] =>
          nat_mult_not_word x; rewrite (natmultcomm x s)
        | context[?x * ?y * s] => nat_mult_not_word y;
            rewrite (nat_mult_perm021 x y s)
      end.

Ltac nat_mult_move_to_front_both_in H s :=
  repeat
    let rhs := get_current_rhs_in H in
    nat_mult_not_at_front rhs s;
      match rhs with
        | context[?x * s] =>
          nat_mult_not_word x; rewrite (natmultcomm x s) in H
        | context[?x * ?y * s] => nat_mult_not_word y;
            rewrite (nat_mult_perm021 x y s) in H
      end.

Ltac nat_mult_move_to_back_goal s :=
  repeat
    let rhs := get_current_rhs in
    nat_mult_not_at_back rhs s;
      match rhs with
        | context [s * ?x] => rewrite (natmultcomm s x)
        | context[?x * s * ?y] => nat_mult_not_word y;
            rewrite (nat_mult_perm021 x s y)
        | context[s * ?x * ?y] =>
          nat_mult_not_word x; nat_mult_not_word y;
          rewrite (nat_mult_perm201 s x y)
      end.

Ltac nat_mult_move_to_back_both_in H s :=
  repeat
    let rhs := get_current_rhs_in H in
    nat_mult_not_at_back rhs s;
      match rhs with
        | context [s * ?x] => rewrite (natmultcomm s x)
        | context[?x * s * ?y] => nat_mult_not_word y;
            rewrite (nat_mult_perm021 x s y) in H
        | context[s * ?x * ?y] =>
          nat_mult_not_word x; nat_mult_not_word y;
          rewrite (nat_mult_perm201 s x y) in H
      end.

(** *** The tactics.*)

(** We employ the following naming conventions.  By default a tactics given pertain only to equations and operate by default on the left-hand side of equations.  Those that operate on both left- and right-hand sides of the goal are suffixed with [_goal].  Tactics that operate on the left-hand side of equations occurring as hypotheses are suffixed with [_in].  Those that operate on both left- and right-hand sides of equations occurring as hypotheses are suffixed with [_both_in].  Those that opexrate on all sides of goals and hypotheses are suffixeD with [_all].*)

Ltac nat_plus_group s t :=
  nat_plus_move_to_front t; nat_plus_move_to_front s.

Ltac nat_plus_group_goal s t :=
  nat_plus_move_to_front_goal t; nat_plus_move_to_front_goal s.

Ltac nat_plus_group_in H s t :=
  nat_plus_move_to_front_in H t; nat_plus_move_to_front_in H s.

Ltac nat_plus_group_both_in H s t :=
  nat_plus_move_to_front_both_in H t; nat_plus_move_to_front_both_in H s.

Ltac nat_plus_group_all s t :=
  nat_plus_group_goal s t;
  repeat
    match goal with
      | H : _ |- _ => nat_plus_group_both_in H s t
    end.

(** [t] is a term of type [nat] and [nat_plus_group_as] attempts to reorganize the [lhs] of the [goal] to include as a subterm [t].*)
Ltac nat_plus_group_as t :=
  match t with
    | ?x + ?y =>
      nat_plus_not_word y; nat_plus_move_to_front y;
      nat_plus_group_as x
    | ?x => nat_plus_not_word x; nat_plus_move_to_front x
  end.

(** t is a term of type x = y for x, y : nat and nat_plus_group_from attempts to reogranize the lhs of the goal to include as a subterm x.*)
Ltac nat_plus_group_from t :=
  let T := type of t in
  match T with
    | ?lhs = ?rhs => nat_plus_group_as lhs
  end.

Ltac nat_mult_group s t :=
  nat_mult_move_to_front t; nat_mult_move_to_front s.

Ltac nat_mult_group_goal s t :=
  nat_mult_move_to_front_goal t; nat_mult_move_to_front_goal s.

Ltac nat_mult_group_in H s t :=
  nat_mult_move_to_front_in H t; nat_mult_move_to_front_in H s.

Ltac nat_mult_group_both_in H s t :=
  nat_mult_move_to_front_both_in H t; nat_mult_move_to_front_both_in H s.

Ltac nat_mult_group_all s t :=
  nat_mult_group_goal s t;
  repeat
    match goal with
      | H : _ |- _ => nat_mult_group_both_in H s t
    end.

(** [t] is a term of type [nat] and [nat_mult_group_as] attempts to reorganize the [lhs] of the [goal] to include as a subterm [t].*)
Ltac nat_mult_group_as t :=
  match t with
    | ?x + ?y =>
      nat_mult_not_word y; nat_mult_move_to_front y;
      nat_mult_group_as x
    | ?x => nat_mult_not_word x; nat_mult_move_to_front x
  end.

(** [t] is a term of type [x = y] for [x y : nat] and [nat_mult_group_from] attempts to reogranize the [lhs] of the [goal] to include as a subterm [x].*)
Ltac nat_mult_group_from t :=
  let T := type of t in
  match T with
    | ?lhs = ?rhs => nat_mult_group_as lhs
  end.

(** * Tactics pertaining to inequalities.*)

(** ** Preprocessing of the ambient goal and hypotheses.*)

(** *** Helper tactics (which should not be considered as part of the public interface for these tactics).*)
Ltac does_not_have_gth x y :=
  match goal with
    | _ : hProptoType (x > y) |- _ => fail 1
    | |- _ => idtac
  end.

Ltac does_not_have_geh x y :=
  match goal with
    | _ : hProptoType (x >= y) |- _ => fail 1
    | |- _ => idtac
  end.

(** It is convenient to have to only work with either [hzgth]/[hzgeh] or [hzlth]/[hzleh].  We choose the former and the following tactics replace instances of [hzlth]/[hzleh] with the corresponding inequalities involving [hzgth]/[hzgeh].*)
Ltac reverse_lth :=
  repeat
    match goal with
      | H : hProptoType (?y < ?u) |- _ =>
        does_not_have_gth u y; assert (natgth u y); [apply H | ]
    end.

Ltac reverse_leh :=
  repeat
    match goal with
      | H : hProptoType (?y <= ?u) |- _ =>
        does_not_have_geh u y; assert (natgeh u y); [apply H | ]
    end.

Ltac gth_to_geh :=
  repeat
    match goal with
      | H : hProptoType (?x > ?y) |- _ =>
        does_not_have_geh x y; assert (natgeh x y);
        [apply natgthtogeh; assumption |]
    end.

(** Clean the hypotheses in preparation for searching.*)
Ltac nat_dfs_clean := reverse_lth; reverse_leh; gth_to_geh.

(** ** Tactics for solving inequalities involving natural numbers.*)

(** *** Tactics for solving very simple inequalities using known lemmas.*)

(** The following tactic allows immediate solution of common goals involving [natgth] provided that the appropriate hypotheses are available.  We probably want to eventually add additional "hints" here.*)
Ltac natgth_simple :=
  match goal with
    | _ : hProptoType (?x > ?y) |- hProptoType (?x > ?y) => assumption
    | P : hProptoType ((S ?x) > (S ?y)) |- hProptoType (?x > ?y) => apply P
    | |- hProptoType ((S ?x) > ?x) => apply (natgthsnn x)
    | |- hProptoType ((S ?x) > 0) => apply (natgthsn0 x)
    | P : hProptoType (?x > ?y) |- hProptoType ((S ?x) > (S ?y)) => apply P
    | P : hProptoType (?x ≠ 0)%nat |- hProptoType (?x > 0) =>
      apply (natneq0togth0 x P)
    | P : hProptoType (0 ≠ ?x)%nat |- hProptoType (?x > 0) =>
      apply (natneq0togth0 x (natneqtwist x P))
    | P : (?x = 0) -> empty |- hProptoType (?x > 0) =>
      apply (natneq0togth0 x P)
    | P : (0 = ?x) -> empty |- hProptoType (?x > 0) =>
      apply (natneq0togth0 x (natneqtwist x P))
    | |- hProptoType ((S ?x) > ?x) => apply (natgthsnn x)
    | P : hProptoType (?x > ?y) |- hProptoType ((S ?x) > ?y) =>
      apply (natgthtogths x y P)
    | P : hProptoType (?x >= ?y) |- hProptoType ((S ?x) > ?y) =>
      apply (natgehtogthsn x y P)
    | P : hProptoType (?x > ?y),
          Q : hProptoType (?y > ?z) |- hProptoType (?x > ?z) =>
      apply (istransnatgth x y z P Q)
    | P : hProptoType (?x > ?y),
          Q : hProptoType (?y >= ?z) |- hProptoType (?x > ?z) =>
      apply (natgthgehtrans x y z P Q)
    | P : hProptoType (?x >= ?y),
          Q : hProptoType (?y > ?z) |- hProptoType (?x > ?z) =>
      apply (natgehgthtrans x y z P Q)
  end.

Ltac natgeh_simple :=
  match goal with
    | _ : hProptoType (?x >= ?y) |- hProptoType (?x >= ?y) => assumption
    | P : hProptoType (?x >= ?y) |- hProptoType ((S ?x) >= (S ?y)) => apply P
    | P : hProptoType ((S ?x) >= (S ?y)) |- hProptoType (?x >= ?y) =>
      apply P
    | |- hProptoType (?x >= ?x) => apply isreflnatgeh
    | |- hProptoType (?x >= 0) => apply natgehn0
    | |- hProptoType ((S ?x) >= ?x) => apply (natgehsnn x)
    | |- hProptoType (?x >= ?x - ?y) => apply (minusgeh x y)
    | H : hProptoType (?x > ?y) |- hProptoType (?x >= ?y) =>
      apply (natgthtogeh x y H)
    | P : hProptoType (?x >= ?y),
          Q : hProptoType (?y >= ?z) |- hProptoType (?x >= ?z) =>
      apply (istransnatgeh x y z P Q)
    | P : hProptoType ((S ?x) > ?y) |- hProptoType (?x >= ?y) =>
      apply (natgthsntogeh x y P)
  end.

(** *** General tactics for solving inequalities by depth-first search.*)

(** The approach taken here for solving inequalities is to construct from the given collection of hypotheses HH a corresponding directed graph and then to perform a depth-first search of the graph.*)

(** Although we will often employ our search method in order to traverse an acyclic graph, when we are proving that the hypotheses imply [empty] we are forced to consider the cyclic case.  In these cases it may be possible to become trapped in a cycle.  To prevent this from happening we must build helper functions that will allow us to check that the next goal we move to is not one we have previously considered.*)
Ltac make_gth_check x y :=
  let f T :=
      match T with
        | hProptoType (x > y) => fail 1
        | _ => idtac
      end
  in f.

Ltac make_geh_check x y :=
  let f T :=
      match T with
        | hProptoType (x >= y) => fail 1
        | _ => idtac
      end
  in f.

(** Perform depth first search of the graph corresponding to the hypotheses.  In standard continuation passing style we allow a helper ltac function [f] which is admitted to perform certain checks (or which can be ignored as in nat_dfs below).*)

(** TODO: Try instead change.  Think about strengthening clauses.*)
Ltac nat_dfs_body f :=
  natgth_simple
    || natgeh_simple
    || match goal with
         | |- hProptoType (?x < ?y) =>
           let X := fresh "X" in
           assert (natgth y x) as X; [nat_dfs_body f | apply X]
         | |- hProptoType (?x <= ?y) =>
           let X := fresh "X" in
           assert (natgeh y x) as X; [nat_dfs_body f | apply X]
         | _ : hProptoType (?u > ?y) |- hProptoType (?x > ?y) =>
           f (hProptoType (x >= u));
             let g := make_geh_check x u in
             let h := check_cons g f in
             apply (natgehgthtrans x u y); [nat_dfs_body h | assumption]
         | |- hProptoType (?x >= ?y) => f (hProptoType(x >= y));
             let g := make_geh_check x y in
             let h := check_cons g f in
             apply (natgthtogeh x y); nat_dfs_body h
         | _ : hProptoType (?u >= ?y) |- hProptoType (?x >= ?y) =>
           f (hProptoType (x >= u));
             let g := make_geh_check x u in
             let h := check_cons g f in
             apply (istransnatgeh x u y); [nat_dfs_body h | assumption]
         | _ : hProptoType (?x >= ?u) |- hProptoType (?x > ?y) =>
           f (hProptoType (u > y));
             let g := make_gth_check u y in
             let h := check_cons g f in
             apply (natgehgthtrans x u y); [assumption | nat_dfs_body h]
         | _ : hProptoType (?u >= ?y) |- hProptoType (?x > ?y) =>
           f (hProptoType (x > u));
             let g := make_gth_check x u in
             let h := check_cons g f in
             apply (natgthgehtrans x u y); [nat_dfs_body h | assumption]
         | |- hProptoType (?x >= S ?y) =>
           apply natgthtogehsn; nat_dfs_body f
         | |- hProptoType ((S ?x) > ?y) =>
           let g := make_geh_check x y in
           let h := check_cons g f in
           (apply (natgthgehtrans _ x _); [apply natlthnsn | nat_dfs_body h])

         | |- hProptoType (?x > ?y - ?z) =>
           let g := make_gth_check x (y - z) in
           let h := check_cons g f in
           apply (natgthgehtrans x y (y - z));
             [nat_dfs_body h | apply minusgeh]
       end.

Ltac nat_dfs := nat_dfs_clean; nat_dfs_body id_check.

(** * Tactics for deriving contradictions.*)
Ltac nat_eq_contr :=
  let f X := assert empty; [apply X; assumption | contradiction] in
  let i X := assert empty; [apply X; apply idpath | contradiction] in
  match goal with
    | H : ?x = ?y -> empty, _ : ?x = ?y |- _ => f H
    | H : neg (?x = ?y), _ : ?x = ?y |- _ => f H
    | H : ?x = ?x -> empty |- _ => i H
    | H : neg (?x = ?x) |- _ => i H
    | H : hProptoType (?x ≠ ?y)%nat, _ : ?x = ?y |- _ => f H
    | H : hProptoType (?x ≠ ?x)%nat |- _ => i H
    | H : hProptoType (?x ≠ ?y)%nat, _ : ?x = ?y |- _ => f H
    | H : hProptoType (?x ≠ ?x)%nat |- _ => i H
  end.

Ltac nat_simple_contr :=
  assert empty; [
    match goal with
      | H : hProptoType (?x < 0) |- _ => exact (negnatlthn0 x H)
      | H : hProptoType (0 > ?x) |- _ => exact (negnatgth0n x H)
      | H : hProptoType ((S ?x) <= 0) |- _ => exact (negnatlehsn0 x H)
      | H : hProptoType (0 >= (S ?x)) |- _ => exact (negnatgeh0sn x H)
      | H : S ?x = 0 |- _ => exact (negpathssx0 x H)
    end | contradiction].

(** Note that the following tactic may not halt. SHOULD halt now.*)
Ltac nat_ineq_contr_isirrefl :=
  nat_dfs_clean;
  assert empty; [
    match goal with
      | _ : hProptoType (?x > ?x) |- _ => apply (isirreflnatgth x); assumption
      | N : nat |- _ =>
        let f := make_gth_check N N in
        apply (isirreflnatgth N); nat_dfs_body ltac:(f)
    end
  | contradiction].

Ltac nat_absurd :=
  (nat_simple_contr || nat_eq_contr || nat_ineq_contr_isirrefl).

Ltac nat_preclean_1 :=
  repeat
    match goal with
      | |- context [0 - ?n] => change (0 - n) with 0
      | |- context [(S ?n) - 1] => change ((S n) - 1) with (n - 0)
      | |- context[S ?x - S ?y] => change (S x - S y) with (x - y)
    end.

Ltac nat_preclean_2 :=
  repeat rewrite multsnm; repeat rewrite multnsm;
  repeat rewrite natldistr; repeat rewrite natrdistr;
  repeat rewrite natmultn0; repeat rewrite natmult0n;
  repeat rewrite natplusl0; repeat rewrite natplusr0;
  repeat rewrite natminuseqn; repeat rewrite natmultl1;
  repeat rewrite natmultr1; repeat rewrite <- natplusassoc;
  repeat rewrite <- natmultassoc; repeat rewrite minus0r;
  repeat rewrite minusnn0.

Ltac nat_clean := nat_preclean_1; nat_preclean_2.

Ltac nat_preclean_1_in H :=
  repeat
    let T := type of H in
    match T with
      | context [0 - ?n] => change (0 - n) with 0 in H
      | context [(S ?n) - 1] => change ((S n) - 1) with (n - 0) in H
      | context[S ?x - S ?y] => change (S x - S y) with (x - y) in H
    end.

Ltac nat_preclean_2_in H :=
  repeat rewrite multsnm in H; repeat rewrite multnsm in H;
  repeat rewrite natldistr in H; repeat rewrite natrdistr in H;
  repeat rewrite natmultn0 in H; repeat rewrite natmult0n in H;
  repeat rewrite natplusl0 in H; repeat rewrite natplusr0 in H;
  repeat rewrite natminuseqn in H; repeat rewrite natmultl1 in H;
  repeat rewrite natmultr1 in H; repeat rewrite <- natplusassoc in H;
  repeat rewrite <- natmultassoc in H; repeat rewrite minus0r in H;
  repeat rewrite minusnn0 in H.

Ltac nat_clean_in H := nat_preclean_1_in H; nat_preclean_2_in H.

Ltac nat_clean_all :=
  nat_clean;
  repeat
    match goal with
      | H : _ |- _ => nat_clean_in H
    end.

(** * Several somewhat devious experimental tactics.*)

Ltac nat_devious_ineq :=
  match goal with
    | |- hProptoType (?x > ?y) =>
      destruct (natgthorleh x y); [assumption | nat_absurd]
    | |- hProptoType (?x >= ?y) =>
      destruct (natlthorgeh x y); [nat_absurd | assumption]
    | |- hProptoType (?x < ?y) =>
      destruct (natlthorgeh x y); [assumption | nat_absurd]
    | |- hProptoType (?x <= ?y) =>
      destruct (natgthorleh x y); [nat_absurd | assumption]
  end.

(** * Tactics for solving equations.*)

(** ** Helper tactics.*)
Ltac make_check T :=
  let f S :=
      match S with
        | T => fail 1
      end
  in f.

Ltac nat_plus_strip :=
  match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | context [?x] =>
          match rhs with
            | context [x] => nat_plus_move_to_back_goal x;
                apply (ap (λ v, v + x))
          end
      end
  end.

Ltac nat_mult_strip :=
  match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | context [?x] =>
          match rhs with
            | context [x] => nat_mult_move_to_back_goal x;
                apply (ap (λ v, v * x))
          end
      end
  end.

(** ** Some simple solver tactics which are concerned exclusively with equations involving _only_ [+] or _only_ [*].*)
Ltac nat_plus_prezap_body f :=
  match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | rhs => apply idpath
        | 0 => apply pathsinv0; nat_plus_prezap_body f
        | ?x + ?y =>
          match rhs with
            | y + x => apply (natpluscomm x y)
          end
        | _ => (nat_plus_strip; nat_plus_prezap_body f)
      end
    | E : ?l = ?r |- ?lhs = ?rhs => f E;
        let g := make_hyp_check E in
        let h := check_cons g f in
        nat_plus_group_from E; matched_rewrite E; nat_plus_prezap_body h
  end.

Ltac nat_plus_prezap := nat_clean_all; nat_plus_prezap_body id_check.

Ltac nat_mult_prezap_body f :=
  match goal with
    | |- ?lhs = ?rhs =>
      match lhs with
        | rhs => apply idpath
        | 0 => apply pathsinv0; nat_mult_prezap_body f
        | ?x * ?y =>
          match rhs with
            | y * x => apply (natmultcomm x y)
          end
        | _ => (nat_mult_strip; nat_mult_prezap_body f)
      end
    | E : ?l = ?r |- ?lhs = ?rhs => f E;
        let g := make_hyp_check E in
        let h := check_cons g f in
        nat_mult_group_from E; matched_rewrite E; nat_mult_prezap_body h
  end.

Ltac nat_mult_prezap := nat_clean_all; nat_mult_prezap_body id_check.

(** ** A simple solver tactic for mixed [+] [*] equations.*)

Ltac nat_plus_zap_body f :=
  match goal with
    | |- ?lhs = ?rhs =>
      match rhs with
        | ?x + ?y => nat_plus_not_word y;
            match lhs with
              | ?u + ?v =>
                (nat_plus_not_word v;
                 let F := fresh in
                 assert (v = y) as F;
                 [ nat_mult_prezap
                 | rewrite F; apply (ap (λ v, v + y));
                   nat_plus_zap_body f
                 ])
                  || (let l := get_current_lhs in
                      let g := make_check l in
                      let h := check_cons f g in
                      nat_plus_move_to_front v; nat_plus_zap_body h)
            end
        | ?x => nat_plus_not_word x;
            match lhs with
              | ?v => nat_plus_not_word v; nat_mult_prezap
            end
      end
  end.

Ltac nat_plus_zap := nat_plus_zap_body id_check.

(** * Combined tactics for solving equations and inequalities of natural numbers.*)

Ltac nat_simple :=
  match goal with
    | H : hProptoType (?n <= 0) |- ?n = 0 => apply (natleh0tois0 n H)
    | H : hProptoType (0 >= ?n) |- ?n = 0 => apply (nat0gehtois0 n H)
    | H : hProptoType (?n <= 0) |- 0 = ?n =>
      apply pathsinv0; apply (natleh0tois0 n H)
    | H : hProptoType (0 >= ?n) |- 0 = ?n =>
      apply pathsinv0; apply (nat0gehtois0 n H)
    | |- ?x + ?y = ?y + ?x => apply natpluscomm
  end.

Ltac nat_intros :=
  repeat match goal with
           | |- ?x -> ?y => intro
           | |- ∏ _, _ => intro
         end.

Ltac nat_try :=
  repeat
    match goal with
      | H : _ |- _ =>
        let T := type of H in
        match T with
          | nat => fail 1
          | _ => idtac "About to try " H; apply H
        end
    end.

Ltac nat_basic_destruct N := destruct N; nat_intros; nat_clean;
                             (auto || assumption || nat_simple || nat_absurd
                                   || nat_dfs ).

Ltac nat_basic_induction N := induction N; nat_intros; nat_clean;
                              (auto || assumption || nat_simple || nat_absurd
                                    || nat_dfs || nat_try ).

Ltac nat_zap :=
  nat_clean_all;
  try (auto || assumption || nat_simple || nat_absurd || nat_dfs
            || nat_plus_zap || nat_try);
  match goal with
    | N : nat |- _ =>
      nat_basic_destruct N || nat_basic_induction N
  end.

Close Scope nat_scope.
(** * TESTS *)
(*
Unset Ltac Debug.

Section Tests.
  Open Scope nat_scope.

  Hypothesis x y z u v w x' y' z' u' v' w' : nat.

  (** Note that [nat_devious_ineq] also correctly solves all of the tests designed for [nat_dfs].*)

  Lemma test_nat_dfs_0 (i1 : natgth x y) (i2 : natgeh y z)
        (i3 : natgth z u) (i4 : natgeh u v) (i5 : natgeh v w) : natgth x w.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_1 (i1 : natgth x y) (i2 : natgth y z)
        (i3 : natlth u z) (i4 : natgth w u) (i5 : natgth z x') : natgth x x'.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_2 (i1 : natgth x y) (i2 : natlth z y)
        (i3 : natgth u z) : natgth x z.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_3 (i1 : natgth x y) (i2 : natlth z y)
        (i3 : natlth z u) : natgth x z.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_4 (i1 : natgth x y) (i2 : natgth y z)
        (i3 : natlth z u) (i4 : natlth v z) (i5 : natgth v x')
        (i6 : natlth v w) (i7 : natlth z' x') (i8 : natlth u' z')
        (i9 : natgth u y') : natgth x u'.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_5 (i1 : natlth x y) (i2 : natlth y z)
        (i3 : natgth z u) (i4 : natgth v z) (i5 : natlth v x')
        (i6 : natgth v w) (i7 : natgth z' x') (i8 : natgth u' z')
        (i9 : natlth u y') : natlth x u'.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_6 (i1 : natgeh x y) (i2 : natgth y z)
        (i3 : natleh z u) (i4 : natlth v z) (i5 : natgth v x')
        (i6 : natleh v w) (i7 : natlth z' x') (i8 : natlth u' z')
        (i9 : natgeh u y') : natgeh x u'.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_7 (i1 : natleh x y) (i2 : natlth y z)
        (i3 : natgeh z u) (i4 : natgth v z) (i5 : natlth v x')
        (i6 : natgeh v w) (i7 : natgth z' x') (i8 : natgth u' z')
        (i9 : natleh u y') : natleh x u'.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_8 (i1 : natleh x y) (i2 : natlth y z)
        (i3 : natgeh z u) (i4 : natgth v z) (i5 : natlth v x')
        (i6 : natgeh v w) (i7 : natgth z' x') (i8 : natgth u' z')
        (i9 : natleh u y') : natleh x u'.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_10 (i1 : x ≠ 0)%nat (i2 : natgeh x 0) :
    natgth x 0.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_11 (i2 : 0 ≠ x)%nat (i2 : natgeh x 0) :
    natgth x 0.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_12 (i1 : 0 = x -> empty) (i2 : natgeh x 0) :
    natgth x 0.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_dfs_13 (i : natleh y x) (l : natgth y x) : natlth x x.
  Proof.
    intros. nat_dfs.
  Qed.

  Lemma test_nat_absurd_1 (i : natleh x y) (j : natgth x (S z))
        (k : natleh y z) : natgth u v.
  Proof.
    intros. nat_absurd.
  Qed.

  Lemma test_nat_absurd_2 (i : natlth x y) (j : natgeh x (S z))
        (k : natlth y z) : natgth u v.
  Proof.
    intros. nat_absurd.
  Qed.

  Lemma test_nat_absurd_3 x y z u v w (i1 : natgth x y) (i2 : natgeh y z)
        (i3 : natgth z u) (i4 : natgeh u v) (i5 : natgeh v w)
        (i6 : natgeh w x) : natgth x w.
  Proof.
    intros. nat_absurd.
  Qed.

  Lemma test_nat_absurd_4 (i1 : natgth x y) (i2 : natlth z y)
        (i3 : natgth u z) (i4 : natleh x z ) : natgth x z.
  Proof.
    intros. nat_absurd.
  Qed.

  Lemma test_nat_plus_ternary_perm  n m k l : n + m + k + l = l + m + n + k.
  Proof.
    intros. nat_plus_ternary_perm l m k. nat_plus_ternary_perm l m n.
    apply idpath.
  Qed.

  Lemma test_nat_mult_ternary_perm  n m k l : n * m * k * l = k * l * n * m.
  Proof.
    intros. nat_mult_ternary_perm k n m. nat_mult_ternary_perm l n m.
    apply idpath.
  Qed.

  Lemma test_nat_plus_group n m k l : n + m + k + l = k + n + m + l.
  Proof.
    intros. nat_plus_group k n. apply idpath.
  Qed.

  Lemma test_nat_mult_group n m k l : n * m * k * l = k * n * m * l.
  Proof.
    intros. nat_mult_group k n. apply idpath.
  Qed.

  Close Scope nat_scope.

End Tests.
 *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules phase_sem rules_algebra.

Set Implicit Arguments.

Section Cut_Admissibility.

  Hint Resolve ill_cf_perm_bang_t.

  Notation sg := (@eq _).
  Infix "∘" := (Composes comp_ctx) (at level 50, no associativity).
  Infix "⊸" := (Magicwand_l comp_ctx) (at level 51, right associativity).
  Infix "⟜" := (Magicwand_r comp_ctx) (at level 52, left associativity).

  Let cl := cl_ctx ill_cf_provable.

  Let cl_increase X : X ⊆ cl X.
  Proof. apply cl_ctx_increase. Qed.

  Let cl_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof. apply cl_ctx_mono. Qed.

  Let cl_idem X : cl (cl X) ⊆  cl X.
  Proof. apply cl_ctx_idem. Qed.

  Let cl_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof. apply cl_ctx_stable_l; eauto. Qed.

  Let cl_stable_r : forall X Y, X ∘ cl Y ⊆ cl (X ∘ Y).
  Proof. apply cl_ctx_stable_r; eauto. Qed.

  Notation "↓" := (fun A Γ => Γ ⊢cf A).
  Notation K := (fun Δ => { Γ | Δ = ‼Γ }).

  Let dc_closed A : cl (↓A) ⊆ ↓A.
  Proof. apply dc_closed. Qed.

  Let v x := ↓ (£x).

  Let Hv x : cl (v x) ⊆ v x.
  Proof. apply dc_closed. Qed.

  Notation "'⟦' A '⟧'" := (Form_sem cl comp_ctx ∅ K v A) (at level 49).

  Let cl_sem_closed A : cl (⟦A⟧) ⊆ ⟦A⟧.
  Proof. apply closed_Form_sem; eauto. Qed.

  Section Okada.

    (** This is Okada's lemma which states that the interpretation ⟦A⟧
        of A is nearly identical to ↓A,

               A::nil ∈ ⟦A⟧ ⊆ ↓A.

        a result which is similar to what happens in the Lidenbaum construction.
        Indeed, in Lidenbaum construction, one proves

                 ⟦A⟧ ≃ ↓A

        but that result needs the cut-rule.

        The MAJOR difference is that Okada's proof does not require
        the use of cut. It is done by induction on A.

         But first, let us give the algebraic interpretation
         of the rules of the cut-free ILL sequent calculus *)

    Let rule_ax A : ↓A (A::∅).
    Proof. apply ill_cf_ax. Qed.

    Let rule_limp_l A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅).
    Proof.
      apply rule_limp_l_eq; eauto.
      intros ? ? ?; apply ill_cf_limp_l.
    Qed.

    Let rule_limp_r A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B).
    Proof.
      apply rule_limp_r_eq; eauto.
      intros ?; apply ill_cf_limp_r.
    Qed.

    Let rule_rimp_l A B : (cl (sg (B::∅)) ⟜ ↓A) (B o- A::∅).
    Proof.
      apply rule_rimp_l_eq; eauto.
      intros ? ? ?; apply ill_cf_rimp_l.
    Qed.

    Let rule_rimp_r A B : ↓B ⟜ sg (A::∅) ⊆ ↓(B o- A).
    Proof.
      apply rule_rimp_r_eq; eauto.
      intros ?; apply ill_cf_rimp_r.
    Qed.

    Let rule_times_l A B : cl (sg (A::B::nil)) (A⊗B::nil).
    Proof.
      apply rule_times_l_eq.
      intros ? ?; apply ill_cf_times_l.
    Qed.

    Let rule_times_r A B : ↓A ∘ ↓B ⊆ ↓(A⊗B).
    Proof.
      apply rule_times_r_eq; eauto.
      intros ? ?; apply ill_cf_times_r.
    Qed.

    Let rule_with_l1 A B : cl (sg (A::∅)) (A&B::∅).
    Proof.
      apply rule_with_l1_eq.
      intros ? ?; apply ill_cf_with_l1.
    Qed.

    Let rule_with_l2 A B : cl (sg (B::∅)) (A&B::∅).
    Proof.
      apply rule_with_l2_eq.
      intros ? ?; apply ill_cf_with_l2.
    Qed.

    Let rule_with_r A B : ↓A ∩ ↓B ⊆ ↓(A & B).
    Proof.
      apply rule_with_r_eq.
      intros ?; apply ill_cf_with_r.
    Qed.

    Let rule_plus_l A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅).
    Proof.
      apply rule_plus_l_eq.
      intros ? ?; apply ill_cf_plus_l.
    Qed.

    Let rule_plus_r1 A B : ↓A ⊆ ↓(A⊕B).
    Proof.
      apply rule_plus_r1_eq.
      intro; apply ill_cf_plus_r1.
    Qed.

    Let rule_plus_r2 A B : ↓B ⊆ ↓(A⊕B).
    Proof.
      apply rule_plus_r2_eq.
      intro; apply ill_cf_plus_r2.
    Qed.

    Let rule_bang_l A : cl (sg (A::∅)) (!A::∅).
    Proof.
      apply rule_bang_l_eq.
      intros ? ?; apply ill_cf_bang_l.
    Qed.

    Let rule_bang_r A : K ∩ ↓A ⊆ ↓(!A).
    Proof.
      apply rule_bang_r_eq.
      intros ?; apply ill_cf_bang_r.
    Qed.

    Let rule_unit_l : cl (sg ∅) (𝝐::nil).
    Proof.
      apply rule_unit_l_eq.
      intros ?; apply ill_cf_unit_l.
    Qed.

    Let rule_unit_r : sg ∅ ⊆ ↓𝝐.
    Proof.
      apply rule_unit_r_eq.
      apply ill_cf_unit_r.
    Qed.

    Let rule_bot_l : cl (fun _ => False) (⟘::∅).
    Proof.
      apply rule_bot_l_eq, ill_cf_bot_l.
    Qed.

    Let rule_top_r : (fun _ => True) ⊆ ↓⟙ .
    Proof.
      apply rule_top_r_eq, ill_cf_top_r.
    Qed.

    Let mwl_mono (X Y X' Y' : _ -> Type) : X ⊆ X' -> Y ⊆ Y' -> X' ⊸ Y ⊆ X ⊸ Y'.
    Proof. apply magicwand_l_monotone; auto. Qed.

    Let mwr_mono (X Y X' Y' : _ -> Type) : X ⊆ X' -> Y ⊆ Y' -> Y ⟜ X' ⊆ Y' ⟜ X.
    Proof. apply magicwand_r_monotone; auto. Qed.

    Let inc1_prop (K : Type) (X Y : K -> Type)  x : Y ⊆ X -> Y x -> X x.
    Proof. simpl; auto. Qed.

    Let cl_under_closed X Y : cl Y ⊆ Y -> X ⊆ Y -> cl X ⊆ Y.
    Proof. apply cl_closed; eauto. Qed.

    Lemma Okada_formula A : ((sg (A::nil) ⊆ ⟦A⟧) * (⟦A⟧ ⊆ ↓A))%type.
    Proof.
      induction A as [ | [] | A [H1 H2] | [] A [H1 H2] B [H3 H4] ]; auto.
      + split; simpl; auto.
        intros _ []; apply rule_ax.
      + split.
        * intros _ []; apply rule_unit_l.
        * simpl; apply cl_under_closed; auto; apply rule_unit_r.
      + split.
        * intros _ []; apply rule_bot_l.
        * simpl; apply cl_under_closed; auto; intros _ [].
      + split; simpl; auto.
      + split.
        * intros _ [].
          simpl.
          intros Th De B H.
          apply H with (ϴ := !A::nil); split.
          - exists (A::nil); auto.
          - apply inc1_prop with (2 := @rule_bang_l _).
            apply cl_under_closed; auto.
        * simpl; apply cl_under_closed; auto.
          intros x []; apply rule_bang_r; split; auto.
      + split.
        * intros _ [].
          simpl; split.
          - apply cl_under_closed with (2 := H1); auto.
          - apply cl_under_closed with (2 := H3); auto.
        * intros Ga (? & ?); apply rule_with_r; auto.
      + split.
        * intros _ []; simpl.
          apply inc1_prop with (2 := @rule_limp_l _ _).
          apply mwl_mono; auto; apply cl_under_closed; auto.
        * simpl; intros x Hx; apply rule_limp_r.
          revert Hx; apply mwl_mono; auto.
      + split.
        * intros _ []; simpl.
          apply inc1_prop with (2 := @rule_rimp_l _ _).
          apply mwr_mono; auto; apply cl_under_closed; auto.
        * simpl; intros x Hx; apply rule_rimp_r.
          revert Hx; apply mwr_mono; auto.
      + split.
        * intros _ [].
          apply inc1_prop with (2 := @rule_times_l _ _).
          simpl; apply cl_mono.
          intros _ []; constructor 1 with (A::∅) (B::∅); auto.
          red; simpl; auto.
        * simpl; apply cl_under_closed; auto.
          intros x Hx; apply rule_times_r.
          revert Hx; apply composes_monotone; eauto.
      + split.
        * intros _ [].
          apply inc1_prop with (2 := @rule_plus_l _ _).
          simpl; apply cl_mono; eauto.
          intros _ [ [] | [] ]; auto.
        * simpl; apply cl_under_closed; auto.
          intros x [ Hx | Hx ]; auto.
    Qed.

  End Okada.

  Notation "'⟬߭' Γ '⟭'" := (list_Form_sem cl comp_ctx ∅ K v Γ) (at level 49).

  (* We lift the result to contexts, ie list of formulas *)

  Lemma Okada_ctx Γ: ⟬߭Γ⟭  Γ.
  Proof.
    induction Γ as [ | A ga Hga ]; simpl;
      apply cl_increase; auto.
    constructor 1 with (A :: nil) ga; auto.
    + apply Okada_formula; auto.
    + red; auto.
  Qed.

  (* And now we apply the soundness result of relational phase semantics *)

  Let ill_cf_sound := rules_sound ill_cf_perm_bang_t ill_cf_weak_ctx ill_cf_cntr_ctx _ Hv.

  Theorem ill_cut_elimination Γ A : Γ ⊢ A -> { p : Γ ⊢ A | ill_cut_free p }.
  Proof.
    intros H; apply ill_cf_sound with (x := Γ) in H; auto.
    + apply Okada_formula in H; auto.
    + apply Okada_ctx.
  Qed.

End Cut_Admissibility.

Recursive Extraction ill_cut_elimination.

Check ill_cut_elimination.
Print Assumptions ill_cut_elimination.


Require Import Coq.Bool.Bool.
Require Import Coq.derive.Derive.
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Rewriter.Language.Language. Import Language.Compilers.
Require Import Crypto.Language.API. Import Language.API.Compilers.
Require Import Rewriter.Language.Wf. Import Language.Wf.Compilers.
Require Import Crypto.Arithmetic.FancyMontgomeryReduction.
Require Import Crypto.PushButtonSynthesis.FancyMontgomeryReduction.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.Fancy.Prod.
Require Import Crypto.Fancy.Spec.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.

Module Montgomery256.

  Definition N := Eval lazy in (2^256-2^224+2^192+2^96-1).
  Definition N':= (115792089210356248768974548684794254293921932838497980611635986753331132366849).
  Definition R := Eval lazy in (2^256).
  Definition R' := 115792089183396302114378112356516095823261736990586219612555396166510339686400.
  Definition machine_wordsize := 256.

  Derive montred256
         SuchThat (montred N R N' machine_wordsize = ErrorT.Success montred256)
         As montred256_eq.
  Proof. lazy; reflexivity. Qed.

  Lemma Wf_montred256 : API.Wf montred256.
  Proof using Type. eapply Wf_montred, montred256_eq. Qed.

  Lemma montred256_correct :
    COperationSpecifications.MontgomeryReduction.montred_correct N R R' (API.Interp montred256).
  Proof.
    apply montred_correct with (n:=2%nat) (machine_wordsize:=machine_wordsize) (N':=N').
    { lazy. reflexivity. }
    { apply montred256_eq. }
  Qed.

  Lemma montred'_correct_specialized R' (R'_correct : Z.equiv_modulo N (R * R') 1) :
    forall (lo hi : Z),
      0 <= lo < R -> 0 <= hi < R -> 0 <= lo + R * hi < R * N ->
      MontgomeryReduction.montred' N R N' (Z.log2 R) lo hi = ((lo + R * hi) * R') mod N.
  Proof.
    intros.
    apply MontgomeryReduction.montred'_correct with (T:=lo + R * hi) (R':=R') (n:=2%nat);
      try match goal with
            | |- context[R'] => assumption
            | |- context [lo] =>
              try assumption; progress autorewrite with zsimplify cancel_pair; reflexivity
          end; lazy; try split; congruence.
  Qed.

  Definition montred256_fancy' (RegMod RegPInv RegZero lo hi error : positive) :=
    of_Expr 6%positive
            (make_consts [(RegMod, N); (RegZero, 0); (RegPInv, N')])
            montred256
            (lo, (hi, tt))
            error.
  Derive montred256_fancy
         SuchThat (forall RegMod RegPInv RegZero,
                      montred256_fancy RegMod RegPInv RegZero = montred256_fancy' RegMod RegPInv RegZero)
         As montred256_fancy_eq.
  Proof.
    intros.
    cbv [montred256_fancy'].
    lazy - [ADD ADDC SUB MUL128LL MUL128LU MUL128UL MUL128UU RSHI SELC SELM SELL ADDM].
    reflexivity.
  Qed.

  (* TODO: these tactics are duplicated; move them elsewhere (probably translation *)
  Local Ltac wf_subgoal :=
    repeat first [ progress cbn [List.In type.and_for_each_lhs_of_arrow fst snd List.app List.map]
                 | apply expr.wf_smart_App_curried
                 | progress intros
                 | exfalso; assumption
                 | apply conj
                 | exact I
                 | solve [ eauto 50 using or_introl, or_intror, eq_refl with nocore ] ].
  Local Ltac valid_expr_subgoal :=
    repeat match goal with
           | _ => progress intros
           | |- context [valid_ident] => econstructor
           | |- context[valid_scalar] => econstructor
           | |- context [valid_carry] => econstructor
           | _ => reflexivity
           | |- _ <> None => cbn; congruence
           | |- of_prefancy_scalar _ _ _ _ = _ => cbn; solve [eauto]
           end.

  Lemma montred256_fancy_correct :
    forall lo hi error,
      0 <= lo < R ->
      0 <= hi < R ->
      0 <= lo + R * hi < R * N ->
      let RegZero := 1%positive in
      let RegMod := 2%positive in
      let RegPInv := 3%positive in
      let RegHi := 4%positive in
      let RegLo := 5%positive in
      let consts_list := [(RegMod, N); (RegZero, 0); (RegPInv, N')] in
      let arg_list := [(RegHi, hi); (RegLo, lo)] in
      let ctx := make_ctx (consts_list ++ arg_list) in
      let carry_flag := false in
      let last_wrote := (fun x : CC.code => RegZero) in
      let cc := make_cc last_wrote ctx carry_flag in
      interp Pos.eqb wordmax cc_spec (montred256_fancy RegMod RegPInv RegZero RegLo RegHi error) cc ctx = ((lo + R * hi) * R') mod N.
  Proof.
    intros.
    rewrite montred256_fancy_eq.
    cbv [montred256_fancy'].
    rewrite <-montred256_correct by (auto; reflexivity).
    eapply of_Expr_correct with (x2 := (lo, (hi, tt))).
    { cbn; intros; subst RegZero RegMod RegPInv RegHi RegLo.
      intuition; Prod.inversion_prod; subst; cbv. break_innermost_match; congruence. }
    { cbn; intros; subst RegZero RegMod RegPInv RegHi RegLo.
      intuition; Prod.inversion_prod; subst; cbv; congruence. }
    { cbn; intros; subst RegZero RegMod RegPInv RegHi RegLo. tauto. }
    { cbn; intros; subst RegZero RegMod RegPInv RegHi RegLo.
      intuition; Prod.inversion_prod; subst; cbv; congruence. }
    { cbn; intros; subst RegZero RegMod RegPInv RegHi RegLo.
      match goal with |- context [_ mod ?m] => change m with (2 ^ machine_wordsize) end.
      intuition; Prod.inversion_prod; subst; apply Z.mod_small; cbv; try split; congruence. }
    { cbn; intros; subst RegZero RegMod RegPInv RegHi RegLo.
      match goal with |- context [_ mod ?m] => change m with (2 ^ machine_wordsize) end.
      assert (R <= 2 ^ machine_wordsize) by (cbv; congruence).
      intuition; Prod.inversion_prod; subst; apply Z.mod_small; lia. }
    { repeat first [ eapply expr.wf_Proper_list, Wf_montred256
                   | progress cbv [make_pairs consts_list arg_list]
                   | wf_subgoal ]. }
    { cbn. cbv [N' N].
      repeat (econstructor; [ solve [valid_expr_subgoal] | intros ]).
      econstructor. valid_expr_subgoal. }
    { reflexivity. }
  Qed.

  Import Spec.Registers.

  Definition montred256_alloc' lo hi RegPInv :=
    fun errorP errorR =>
      allocate register
               positive Pos.eqb
               errorR
               (montred256_fancy 1000%positive 1001%positive 1002%positive 1003%positive 1004%positive errorP)
               [r2;r3;r4;r5;r6;r7;r8;r9;r10;r11;r12;r13;r14;r15;r16;r17;r18;r19;r20]
               (fun n => if n =? 1000 then RegMod
                         else if n =? 1001 then RegPInv
                              else if n =? 1002 then RegZero
                                   else if n =? 1003 then lo
                                        else if n =? 1004 then hi
                                                 else errorR)%positive.
  Derive montred256_alloc
         SuchThat (montred256_alloc = montred256_alloc')
         As montred256_alloc_eq.
  Proof.
    intros.
    cbv [montred256_alloc' montred256_fancy].
    cbn. subst montred256_alloc.
    reflexivity.
  Qed.

  Local Notation interp := (interp reg_eqb wordmax cc_spec).
  Lemma montred256_alloc_equivalent errorP errorR cc_start_state start_context :
    forall lo hi y t1 t2 scratch RegPInv extra_reg,
      NoDup [lo; hi; y; t1; t2; scratch; RegPInv; extra_reg; RegMod; RegZero] ->
      0 <= start_context lo < R ->
      0 <= start_context hi < R ->
      0 <= start_context RegPInv < R ->
      interp
        (montred256_alloc r0 r1 r30 errorP errorR) cc_start_state
                          (fun r => if reg_eqb r r0
                                    then start_context lo
                                    else if reg_eqb r r1
                                         then start_context hi
                                         else if reg_eqb r r30
                                              then start_context RegPInv
                                              else start_context r)
    = interp (Prod.MontRed256 lo hi y t1 t2 scratch RegPInv) cc_start_state start_context.
  Proof.
    intros. cbv [R] in *.
    cbv [Prod.MontRed256 montred256_alloc].

    (* Extract proofs that no registers are equal to each other *)
    repeat match goal with
           | H : NoDup _ |- _ => inversion H; subst; clear H
           | H : ~ In _ _ |- _ => cbv [In] in H
           | H : ~ (_ \/ _) |- _ => apply Decidable.not_or in H; destruct H
           | H : ~ False |- _ => clear H
           end.

    Time repeat match goal with
                | _ => progress prove_programs_equivalent
                | _ => rewrite interp_Mul256 with (tmp2 := extra_reg) by
                      (match goal with
                       | |- _ <> _ => assumption || congruence
                       | _ => push_value_unused
                       end)
                | _ => rewrite interp_Mul256x256 with (tmp2 := extra_reg) by
                      (match goal with
                       | |- _ <> _ => assumption || congruence
                       | _ => push_value_unused
                       end)
                end.

    cbn [Spec.interp]; simplify_with_register_properties.
    reflexivity.
  Qed.

  Lemma prod_montred256_correct :
    forall (cc_start_state : CC.state) (* starting carry flags can be anything *)
           (start_context : register -> Z)   (* starting register values *)
           (lo hi y t1 t2 scratch RegPInv extra_reg : register), (* registers to use in computation *)
      NoDup [lo; hi; y; t1; t2; scratch; RegPInv; extra_reg; RegMod; RegZero] -> (* registers must be distinct *)
      start_context RegPInv = N' ->  (* RegPInv needs to hold the inverse of the modulus *)
      start_context RegMod = N ->    (* RegMod needs to hold the modulus *)
      start_context RegZero = 0 ->   (* RegZero needs to hold zero *)
      (0 <= start_context lo < R) -> (* low half of the input is in bounds (R=2^256) *)
      (0 <= start_context hi < R) -> (* high half of the input is in bounds (R=2^256) *)
      let x := (start_context lo) + R * (start_context hi) in (* x is the input (split into two registers) *)
      (0 <= x < R * N) -> (* input precondition *)
      (interp (Prod.MontRed256 lo hi y t1 t2 scratch RegPInv) cc_start_state start_context = (x * R') mod N).
  Proof.
    intros. subst x.
    erewrite <-montred256_fancy_correct with (error:=100000%positive) by eauto.
    rewrite <-montred256_alloc_equivalent with (errorR := RegZero) (errorP := 1%positive) (extra_reg:=extra_reg)
      by (cbv [R N N'] in *; auto with lia).

    (* TODO: factor out this tactic *)
    match goal with
      |- context [make_cc ?last_wrote ?ctx ?carry] =>
      let e := fresh in
      let He := fresh in
      remember (make_cc last_wrote ctx carry) as e eqn:He;
        cbv [make_ctx app make_cc] in He;
        cbn [Pos.eqb] in He; autorewrite with zsimplify in He;
          subst e
    end.
    cbv [montred256_alloc montred256_fancy].
    repeat match goal with
             H : context [start_context] |- _ =>
             rewrite <-H end.
    repeat step.
    reflexivity.
  Qed.
End Montgomery256.

Section with_notations.
  Import Crypto.Language.IdentifiersBasicGENERATED.Compilers.
  Import Crypto.Util.ZRange.
  Local Open Scope zrange_scope.
  Local Open Scope Z_scope.
  Local Open Scope expr_scope.
  Local Notation uint256 := r[0 ~> 115792089237316195423570985008687907853269984665640564039457584007913129639935]%zrange.
  Local Set Printing Width 500.
  Redirect "Crypto.Fancy.Montgomery256.montred256" Print Montgomery256.montred256.
End with_notations.

Import Registers.

(* Notations to make code more readable *)
Local Notation "i rd x y ; cont" := (Instr i rd (x, y) cont) (at level 40, cont at level 200, format "i  rd  x  y ; '//' cont").
Local Notation "i rd x y z ; cont" := (Instr i rd (x, y, z) cont) (at level 40, cont at level 200, format "i  rd  x  y  z ; '//' cont").

(* Montgomery reference code : *)
Local Set Printing Width 150.
Redirect "Crypto.Fancy.Montgomery256.Prod.MontRed256" Eval cbv beta iota delta [Prod.MontRed256 Prod.Mul256 Prod.Mul256x256] in Prod.MontRed256.
(*
     = fun lo hi y t1 t2 scratch RegPInv : register =>
       MUL128LL y lo RegPInv;
       MUL128UL t1 lo RegPInv;
       ADD 128 y y t1;
       MUL128LU t1 lo RegPInv;
       ADD 128 y y t1;
       MUL128LL t1 y RegMod;
       MUL128UU t2 y RegMod;
       MUL128UL scratch y RegMod;
       ADD 128 t1 t1 scratch;
       ADDC (-128) t2 t2 scratch;
       MUL128LU scratch y RegMod;
       ADD 128 t1 t1 scratch;
       ADDC (-128) t2 t2 scratch;
       ADD 0 lo lo t1;
       ADDC 0 hi hi t2;
       SELC y RegMod RegZero;
       SUB 0 lo hi y;
       ADDM lo lo RegZero RegMod;
       Ret lo
 *)

(* Remove Redirect to see proof statement and remaining admitted statements,
or search for "prod_montred256_correct" to see comments on the proof
preconditions. *)
Redirect "Crypto.Fancy.Montgomery256.prod_montred256_correct" Check Montgomery256.prod_montred256_correct.
Redirect "Crypto.Fancy.Montgomery256.prod_montred256_correct.Assumptions" Print Assumptions Montgomery256.prod_montred256_correct.


Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros.
  transitivity m.
  apply H0.
  apply H.
Qed.


Require Export base_mods SO_syntax.
Require Import Pred_in_SO.

Inductive lPred_in_SO (alpha : SecOrder) : list predicate -> Prop :=
| lPred_nil : lPred_in_SO alpha nil
| lPred_cons : forall P lP, Pred_in_SO alpha P -> lPred_in_SO alpha lP ->
                            lPred_in_SO alpha (P :: lP).