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

Add LoadPath "basis".

(** * Permutation over lists, and finite multisets. *)

Set Implicit Arguments.

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

Inductive permut0 (A B : Set) (R : A -> B -> Prop) : (list A -> list B -> Prop) :=
  | Pnil : permut0 R nil nil
  | Pcons : forall a b l l1 l2, R a b -> permut0 R l (l1 ++ l2) ->
                   permut0 R (a :: l) (l1 ++ b :: l2).

Lemma permut_nil :
  forall (A B : Set) (R : A -> B -> Prop) l, permut0 R l nil -> l = nil.
Proof.
intros A B R l P; inversion P as [ | a b l' l1 l2 a_R_b P']; trivial.
destruct l1; discriminate.
Qed.

Lemma permut_impl :
  forall (A B : Set) (R R' : A -> B -> Prop) l1 l2,
  (forall a b, R a b -> R' a b) -> permut0 R l1 l2 -> permut0 R' l1 l2.
Proof.
intros A B R R' l1; induction l1 as [ | a1 l1]; intros l2 Compat P;
inversion P as [ | a b k k1 k2 a_R_b Q]; subst.
apply Pnil.
apply Pcons.
apply Compat; trivial.
apply IHl1; trivial.
Qed.

Lemma permut_strong :
  forall (A B : Set) (R : A -> B -> Prop) a1 a2 l1 k1 l2 k2,
  R a1 a2 -> permut0 R (l1 ++ k1) (l2 ++ k2) ->
  permut0 R (l1 ++ a1 :: k1) (l2 ++ a2 :: k2).
Proof.
intros A B R a1 a2 l1; induction l1 as [ | u1 l1];
intros k1 l2 k2 a1_R_a2 P.
apply (@Pcons _ _ R a1 a2 k1 l2 k2); trivial.
inversion P as [ | b1 b2 l k k' b1_R_b2 Q]; clear P; subst.
destruct (split_list _ _ _ _ H) as [H' | H']; clear H.
destruct H' as [l [H1 H2]]; subst; simpl.
assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) (l2 ++ a2 :: l) k' b1_R_b2).
do 2 rewrite <- ass_app in Q'; simpl in Q'; apply Q'.
apply IHl1; trivial.
rewrite ass_app; trivial.
destruct H' as [l [H1 H2]]; subst; simpl.
destruct l as [ | u l].
simpl in H2; subst k2; rewrite <- app_nil_end.
assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) (k ++ a2 :: nil) k' b1_R_b2).
do 2 rewrite <- ass_app in Q'; simpl in Q'; apply Q'.
apply IHl1; trivial.
simpl in H2; injection H2; clear H2; intros H2 b2_eq_u; subst u k'.
assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) k (l ++ a2 :: k2) b1_R_b2).
rewrite <- ass_app; simpl; apply Q'.
rewrite ass_app; apply IHl1; trivial.
rewrite <- ass_app; trivial.
Qed.

Lemma permut_inv_left_strong :
  forall (A B : Set) (R : A -> B -> Prop) a l1' l1'' l2,
  permut0 R (l1' ++ a :: l1'') l2 -> exists b, exists l2', exists l2'',
   (R a b /\ l2 = l2' ++ b :: l2'' /\ permut0 R (l1' ++ l1'') (l2' ++ l2'')).
Proof.
intros A B R a l1'; generalize a; clear a;
induction l1' as [ | a1 l1']; intros a l1'' l2 P.
inversion P as [ | a' b l' l2' l2'' a_R_b Q H]; clear P; subst.
exists b; exists l2'; exists l2''; repeat split; trivial.
inversion P as [ | a1' b l' l2' l2'' a1_R_b Q H]; clear P; subst.
destruct (IHl1' _ _ _ Q) as [b' [k2' [k2'' [a_R_b' [H Q']]]]]; clear Q.
destruct (split_list _ _ _ _ H) as [H' | H']; clear H.
destruct H' as [[ | b'' l] [H1 H2]]; simpl in *; subst.
exists b'; exists (k2' ++ b :: nil); exists k2''; repeat split; trivial.
rewrite <- app_nil_end; rewrite <- ass_app; simpl; trivial.
rewrite <- ass_app; simpl; apply Pcons; trivial.
injection H2; clear H2; intros; subst.
exists b''; exists k2'; exists (l ++ b :: l2''); repeat split; trivial.
rewrite <- ass_app; simpl; trivial.
rewrite ass_app; apply Pcons; trivial; rewrite <- ass_app; trivial.
destruct H' as [l [H1 H2]]; subst.
exists b'; exists (l2' ++ b :: l); exists k2''; repeat split; trivial.
rewrite <- ass_app; simpl; trivial.
rewrite <- ass_app.
do 2 rewrite <- app_comm_cons; apply Pcons; trivial; rewrite ass_app; trivial.
Qed.

Lemma permut_inv_right :
  forall (A : Set) (R : relation A) b l1 l2,
  permut0 R l1 (b :: l2) -> exists a, exists l1', exists l1'',
   (R a b /\ l1 = l1' ++ a :: l1'' /\ permut0 R (l1' ++ l1'') l2).
Proof.
intros A R b l1; generalize b; clear b;
induction l1 as [ | a1 l1]; intros b l2 P;
inversion P as [ | a b' l' l1' l2' a_R_b' Q H]; subst.
destruct l1' as [ | a1' l1']; injection H2; clear H2; intros; subst.
exists a1; exists (@nil A); exists l1; repeat split; trivial.
simpl in Q; destruct (IHl1 _ _ Q) as [a [k1' [k1'' [a_R_b [H Q']]]]]; subst.
exists a; exists (a1 :: k1'); exists k1''; repeat split; trivial.
simpl; apply (@Pcons _ _ R a1 b' (k1' ++ k1'') l1' l2'); trivial.
Qed.

Lemma permut_inv_right_strong :
  forall (A B : Set) (R : A -> B -> Prop) b l1 l2' l2'',
  permut0 R l1 (l2' ++ b :: l2'') -> exists a, exists l1', exists l1'',
   (R a b /\ l1 = l1' ++ a :: l1'' /\ permut0 R (l1' ++ l1'') (l2' ++ l2'')).
Proof.
intros A B R b l1; generalize b; clear b;
induction l1 as [ | a1 l1]; intros b l2' l2'' P;
inversion P as [ | a b' l' l1' k2 a_R_b' Q H]; subst.
destruct l2'; discriminate.
destruct (in_in_split_set _ _ _ _ _ _ H2) as [[H2' | H2'] | H2']; clear H2.
destruct H2' as [l [H2 H3]]; subst.
rewrite <- ass_app in Q; simpl in Q;
destruct (IHl1 b _ _ Q) as [a [l1' [l1'' [a_R_b [H Q']]]]]; subst.
exists a; exists (a1 :: l1'); exists l1''; repeat split; trivial.
simpl; rewrite ass_app; apply Pcons; trivial.
rewrite <- ass_app; trivial.
destruct H2' as [l [H2 H3]]; subst.
rewrite ass_app in Q.
destruct (IHl1 b _ _ Q) as [a [k1' [k1'' [a_R_b [H Q']]]]]; subst.
exists a; exists (a1 :: k1'); exists k1''; repeat split; trivial.
rewrite <- ass_app; simpl; apply Pcons; trivial.
rewrite ass_app; trivial.
destruct H2' as [b'_eq_b [H2 H3]]; subst.
exists a1; exists (@nil A); exists l1; repeat split; trivial.
Qed.

Lemma permut_rev :
  forall (A B : Set) (R : A -> B -> Prop) l1 l2, permut0 R l1 l2 ->
  permut0 (fun b a => R a b) l2 l1.
Proof.
intros A B R l1; induction l1 as [ | a1 l1]; intros l2 P;
inversion P as [ | a b l1' l2' l2'' a_R_b Q]; subst.
apply Pnil.
apply (@permut_strong B A (fun b a => R a b) b a1 l2' l2'' (@nil _) l1); trivial.
simpl; apply IHl1; trivial.
Qed.

(** Permutation is compatible with length. *)
Lemma permut_length :
  forall (A : Set) (R : relation A) l1 l2, permut0 R l1 l2 -> length l1 = length l2.
Proof.
intros A R l; induction l as [ | a l]; intros l' P; inversion P; trivial.
subst.
rewrite length_app; simpl; rewrite plus_comm; simpl; rewrite plus_comm.
rewrite <- length_app; rewrite (IHl (l1 ++ l2)); trivial.
Qed.

Lemma permut_refl :
   forall (A : Set) (R : relation A) l,
  (forall a, In a l -> R a a) -> permut0 R l l.
Proof.
intros A R l refl_R; induction l as [ | a l].
apply Pnil.
apply (@Pcons _ _ R a a l nil l).
apply refl_R; left; trivial.
simpl; apply IHl; intros; apply refl_R; right; trivial.
Qed.

Lemma permut_sym :
  forall (A : Set) (R : relation A) l1 l2,
   (forall a b, In a l1 -> In b l2 -> R a b -> R b a) ->
   permut0 R l1 l2 -> permut0 R l2 l1.
Proof.
intros A R l1; induction l1 as [ | a1 l1]; intros l2 sym_R P;
inversion P as [ | a b l1' l2' l2'' a_R_b Q]; subst.
apply Pnil.
apply (permut_strong (R := R) b a1 l2' l2'' (@nil A) l1).
apply sym_R; trivial; [left | apply in_or_app; right; left]; trivial.
simpl; apply IHl1; trivial.
intros; apply sym_R; trivial; [right | apply in_insert]; trivial.
Qed.

Lemma permut_trans :
  forall (A : Set) (R : relation A) l1 l2 l3,
   (forall a b c, In a l1 -> In b l2 -> In c l3 -> R a b -> R b c -> R a c) ->
   permut0 R l1 l2 -> permut0 R l2 l3 -> permut0 R l1 l3.
Proof.
intros A R l1 l2; generalize l1; clear l1;
induction l2 as [ | a2 l2]; intros l1 l3 trans_R P1 P2.
inversion_clear P2; trivial.
destruct (permut_inv_right P1) as [a1 [l1' [l1'' [a1_R_a2 [H Q1]]]]]; subst l1.
inversion P2 as [ | a2' a3 l2' l3' l3'' a2_R_a3 Q2]; subst.
apply permut_strong.
apply trans_R with a2; trivial.
apply in_or_app; right; left; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
apply IHl2; trivial.
intros a b c; intros; apply trans_R with b; trivial.
apply in_insert; trivial.
right; trivial.
apply in_insert; trivial.
Qed.

Lemma permut_cons_inside :
  forall (A B : Set) (R : A -> B -> Prop) a b l l1 l2,
  (forall a1 b1 a2 b2, In a1 (a :: l) -> In b1 (l1 ++ b :: l2) ->
                   In a2 (a :: l) -> In b2 (l1 ++ b :: l2) ->
                   R a1 b1 -> R a2 b1 -> R a2 b2 -> R a1 b2) ->
  R a b -> permut0 R (a :: l) (l1 ++ b :: l2) -> permut0 R l (l1 ++ l2).
Proof.
intros A B R a b l l1 l2 trans_R a_R_b P;
destruct (permut_inv_right_strong (R := R) _ _ _ P) as [a' [l1' [l1'' [a'_R_b [H P']]]]].
destruct l1' as [ | a1' l1']; injection H; clear H; intros; subst; trivial.
inversion P' as [ | a'' b' l' k1' k2' a''_R_b' P'']; subst.
apply permut_strong; trivial.
apply trans_R with b a1'; trivial.
right; apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
left; trivial.
apply in_insert; rewrite <- H; apply in_or_app; right; left; trivial.
Qed.

Lemma permut_add_inside :
   forall (A B : Set) (R : A -> B -> Prop) a b l1 l1' l2 l2',
  (forall a1 b1 a2 b2, In a1 (l1 ++ a :: l1') -> In b1 (l2 ++ b :: l2') ->
                   In a2 (l1 ++ a :: l1') -> In b2 (l2 ++ b :: l2') ->
                   R a1 b1 -> R a2 b1 -> R a2 b2 -> R a1 b2) ->
  R a b -> permut0 R (l1 ++ a :: l1') (l2 ++ b :: l2') -> permut0 R (l1 ++ l1') (l2 ++ l2').
Proof.
intros A B R a b l1 l1' l2 l2' trans_R a_R_b P.
destruct (permut_inv_left_strong (R := R) _ _ _ P) as [b' [k2 [k2' [a_R_b' [H P']]]]].
destruct (in_in_split_set _ _ _ _ _ _ H) as [[H' | H'] | H']; clear H.
destruct H' as [l [H1 H2]]; subst.
rewrite ass_app in P'.
destruct (permut_inv_right_strong (R := R) _ _ _ P') as [a' [k1' [k1'' [a'_R_b' [H P'']]]]].
rewrite H; rewrite <- ass_app; simpl; apply permut_strong.
apply trans_R with b a; trivial.
apply in_insert; rewrite H; apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; left; apply in_or_app; right; left; trivial.
rewrite ass_app; trivial.
destruct H' as [l [H1 H2]]; subst.
rewrite <- ass_app in P'; simpl in P'.
destruct (permut_inv_right_strong (R := R) _ _ _ P') as [a' [k1' [k1'' [a'_R_b' [H P'']]]]].
rewrite H; rewrite ass_app; simpl; apply permut_strong.
apply trans_R with b a; trivial.
apply in_insert; rewrite H; apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; right; right; apply in_or_app; right; left; trivial.
rewrite <- ass_app; trivial.
destruct H' as [H1 [H2 H3]]; subst; trivial.
Qed.

Lemma exists_dec :
  forall (A : Set) (P : A -> Prop) (l : list A),
  (forall a, In a l -> {P a}+{~P a}) ->
  {a | In a l /\ P a}+{~exists a, In a l /\ P a}.
Proof.
intros A P l P_dec; induction l as [ | a l].
right; intros [a [a_in_nil _]]; absurd (In a nil); auto.
destruct (P_dec a) as [Pa | not_Pa].
left; trivial.
left; exists a; split; trivial; left; trivial.
destruct IHl as [Ok | Ko].
intros; apply P_dec; right; trivial.
destruct Ok as [b [b_in_l P_b]].
left; exists b; split; trivial; right; trivial.
right; intros [b [[b_eq_a | b_in_l] Pb]].
subst; apply not_Pa; trivial.
apply Ko; exists b; split; trivial.
Defined.

Fixpoint split_all (A : Set) (l : list A) : list (A * (list A * list A)) :=
  match l with
  | nil => @nil _
  | a :: l =>
    (a,(@nil _, l)) ::
    (map (fun bl' => match bl' with (b,(l',l'')) => (b, (a :: l',l'')) end) (split_all l))
    end.

Lemma split_all_is_sound :
  forall (A : Set) (l  : list A) b l' l'', In (b,(l',l'')) (split_all l) <-> l = l' ++ b :: l''.
Proof.
intros A l; induction l as [ | a l]; intros b l' l''.
split; intro H.
contradiction.
destruct l'; discriminate.
simpl; split; intro H.
rewrite in_map_iff in H; destruct H as [ H | H ].
injection H; intros; subst; trivial.
destruct H as [[c [k' k'']] [H H']].
injection H; intros; subst.
simpl; apply (f_equal (fun l => a :: l)).
rewrite <- (IHl b k' l''); trivial.
rewrite in_map_iff; destruct l' as [ | a' l'];
simpl in H; injection H; intros; subst.
left; trivial.
right; exists (b,(l',l'')); split; trivial.
rewrite (IHl b l' l''); trivial.
Qed.

Lemma permut_dec :
  forall (A B : Set) (R : A -> B -> Prop),
          forall l1 l2, (forall a1 a2, In a1 l1 -> In a2 l2 -> {R a1 a2}+{~R a1 a2}) ->
         {permut0 R l1 l2}+{~permut0 R l1 l2}.
Proof.
intros A B R l1; induction l1 as [ | a1 l1]; intros l2 R_dec.
destruct l2 as [ | a2 l2].
left; apply Pnil.
right; intro P; inversion P.
assert (P_dec : forall a : B * (list B * list B),
  In a (split_all l2) ->
  {(fun bll' : B * (list B * list B) =>
    let (b, y) := bll' in let (l, l') := y in R a1 b /\ permut0 R l1 (l ++ l'))
     a} +
  {~
   (fun bll' : B * (list B * list B) =>
    let (b, y) := bll' in let (l, l') := y in R a1 b /\ permut0 R l1 (l ++ l'))
     a}).
intros [b [l l']] H; rewrite split_all_is_sound in H.
destruct (R_dec a1 b) as [a1_R_b | not_a1_R_b].
left; trivial.
subst l2; apply in_or_app; right; left; trivial.
destruct (IHl1 (l ++ l')) as [P | not_P].
intros; apply R_dec.
right; trivial.
subst l2; apply in_insert; trivial.
left; split; trivial.
right; intros [_ P]; apply not_P; trivial.
right; intros [a1_R_b _]; apply not_a1_R_b; trivial.

assert (H := list_exists_rest_is_sound
                       (fun bll' =>
                           match bll' with
                           | (b,(l,l')) => R a1 b /\ permut0 R l1 (l ++ l')
                           end) (split_all l2) P_dec).
destruct (list_exists_rest
      (fun bll' : B * (list B * list B) =>
       let (b, y) := bll' in
       let (l, l') := y in R a1 b /\ permut0 R l1 (l ++ l')) (split_all l2) P_dec).
left.
destruct ((proj1 H) (refl_equal _)) as [[b [l l']] [H' [a1_R_b P]]].
rewrite split_all_is_sound in H'; subst l2; apply Pcons; trivial.
right; intro P; inversion P; subst.
assert (false = true).
rewrite H; exists (b,(l0,l3)); split; trivial.
rewrite split_all_is_sound; trivial.
split; trivial.
discriminate.
Defined.

Lemma permut_map :
  forall (A B A' B': Set) (R : A -> B -> Prop) (R' : A' -> B' -> Prop) (f1 : A -> A') (f2 : B -> B')
  l1 l2, (forall a b, In a l1 -> In b l2 -> R a b -> R' (f1 a) (f2 b)) ->
  permut0 R l1 l2 -> permut0 R' (map f1 l1) (map f2 l2).
Proof.
intros A B A' B' R R' f1 f2 l1; induction l1 as [ | a1 l1];
intros l2 Compat P; inversion P as [ | a' b l1' l2' l2'' a_R_b P' H]; subst.
simpl; apply Pnil.
rewrite map_app; simpl; apply Pcons.
apply Compat; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
rewrite <- map_app; apply IHl1; trivial.
intros a b' a_in_l1 b'_in_l2; apply Compat.
right; trivial.
apply in_insert; trivial.
Qed.

Lemma permut_length_1:
  forall (A B : Set) (R : A -> B -> Prop) a b, permut0 R (a :: nil) (b :: nil)  -> R a b.
Proof.
intros A B R a b P; inversion P as [ | a' b' l' l1' l2' a_R_b' P' H1 H']; subst.
destruct l1' as [ | a1' [ | b1' l1']].
injection H'; intros; subst; trivial.
discriminate.
discriminate.
Qed.

Lemma permut_length_2 :
 forall (A B : Set) (R : A -> B -> Prop) a1 b1 a2 b2,
    permut0 R (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
    (R a1 a2 /\ R b1 b2) \/ (R a1 b2 /\ R b1 a2).
Proof.
intros A B R a1 b1 a2 b2 P;
inversion P as [ | a b l l1 l2 a_R_b P' H1 H']; subst.
destruct l1 as [ | c1 l1].
destruct l2 as [ | c2 [ | d2 l2]].
discriminate.
injection H'; intros; subst.
left; split; trivial.
apply (permut_length_1 P').
discriminate.
destruct l1 as [ | d1 l1].
destruct l2 as [ | c2 l2].
injection H'; intros; subst.
right; split; trivial.
apply (permut_length_1 P').
discriminate.
destruct l1; discriminate.
Qed.

Lemma permut_size :
  forall (A B : Set) (R : A -> B -> Prop) size size' l1 l2,
  (forall a a', In a l1 -> In a' l2 -> R a a' -> size a = size' a') ->
  permut0 R l1 l2 -> list_size size l1 = list_size size' l2.
Proof.
intros A B R size size' l1; induction l1 as [ | a1 l1 ]; intros l2 E P;
inversion P as [ | a b l1' l2' l2'' a_R_b P']; subst; trivial.
rewrite list_size_app; simpl.
rewrite (E a1 b); trivial.
rewrite (IHl1 (l2' ++ l2'')); trivial.
rewrite list_size_app; simpl.
rewrite plus_comm.
rewrite <- plus_assoc.
apply (f_equal (fun n => list_size size' l2' + n)).
apply plus_comm.
intros a a' a_in_la a_in_l'; apply E; trivial.
right; trivial.
apply in_insert; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
Qed.

Lemma in_permut_in :
   forall (A : Set) l1 l2, permut0 (@eq A) l1 l2 -> (forall a, In a l1 <-> In a l2).
Proof.
assert (H : forall (A : Set) l1 l2, permut0 (@eq A) l1 l2 -> forall a, In a l2 -> In a l1).
intros A l1 l2 P a a_in_l2;
destruct (In_split _ _ a_in_l2) as [l2' [l2'' H]]; subst.
destruct (permut_inv_right_strong (R := @eq A) _ _ _ P)
  as [a' [l1' [l1'' [a_eq_a' [H _]]]]]; subst.
apply in_or_app; right; left; trivial.
intros A l1 l2 P a; split; apply H; trivial.
apply permut_sym; trivial; intros; subst; trivial.
Qed.

(** Permutation is compatible with append. *)
Lemma permut_app :
  forall (A B : Set) (R : A -> B -> Prop) l1 l1' l2 l2',
   permut0 R l1 l2 -> permut0 R l1' l2' -> permut0 R (l1 ++ l1') (l2 ++ l2').
Proof.
intros A B R l1; induction l1 as [ | a1 l1];
intros l1' l2 l2' P P'.
inversion_clear P; trivial.
inversion P as [ | a b l1'' l2'' l2''' a_R_b Q]; subst.
simpl; rewrite <- ass_app; simpl; apply Pcons; trivial.
rewrite ass_app; apply IHl1; trivial.
Qed.

Lemma permut_swapp :
  forall (A B : Set) (R : A -> B -> Prop) l1 l1' l2 l2',
   permut0 R l1 l2 -> permut0 R l1' l2' -> permut0 R (l1 ++ l1') (l2' ++ l2).
Proof.
intros A B R l1; induction l1 as [ | a1 l1];
intros l1' l2 l2' P P'.
inversion_clear P; rewrite <- app_nil_end; trivial.
inversion P as [ | a b l1'' l2'' l2''' a_R_b Q]; subst.
simpl; rewrite ass_app; apply Pcons; trivial.
rewrite <- ass_app; apply IHl1; trivial.
Qed.

Instance equivalence_coercion (A : Set) (R : relation A) (E : equivalence _ R) : Equivalence R.
revert E;intros [E1 E2 E3].
split; assumption.
Qed.

Lemma permut_app1 :
  forall (A : Set) (R : relation A), equivalence _ R ->
  forall l l1 l2, permut0 R l1 l2 <-> permut0 R (l ++ l1) (l ++ l2).
Proof.
intros A R E l l1 l2; split; intro P.
(* -> case *)
induction l as [ | u l]; trivial.
simpl; apply (@Pcons _ _ R u u (l ++ l1) (@nil A) (l ++ l2)); trivial.
apply (equiv_refl _ _ E).
(* <- case *)
induction l as [ | u l]; trivial.
apply IHl.
apply (@permut_cons_inside A A R u u (l ++ l1) (@nil _) (l ++ l2)); trivial.
intros a1 b1 a2 b2 _ _ _ _ a1_R_b1 a2_R_b1 a2_R_b2.
apply (equiv_trans _ _ E) with b1; trivial.
apply (equiv_trans _ _ E) with a2; trivial.
apply (equiv_sym _ _ E); trivial.
apply (equiv_refl _ _ E).
Qed.

Lemma permut_app2 :
  forall (A : Set) (R : relation A), equivalence _ R ->
  forall l l1 l2, permut0 R l1 l2 <-> permut0 R (l1 ++ l) (l2 ++ l).
Proof.
intros A R E l l1 l2; split; intro P.
(* -> case *)
induction l as [ | u l].
do 2 rewrite <- app_nil_end; trivial.
apply permut_strong; trivial.
apply (equiv_refl _ _ E).

(* <- case *)
induction l as [ | u l].
do 2 rewrite <- app_nil_end in P; trivial.
apply IHl.
apply (@permut_add_inside A A R u u); trivial.
intros a1 b1 a2 b2 _ _ _ _ a1_R_b1 a2_R_b1 a2_R_b2;
apply (equiv_trans _ _ E) with b1; trivial.
apply (equiv_trans _ _ E) with a2; trivial.
apply (equiv_sym _ _ E); trivial.
apply (equiv_refl _ _ E).
Qed.

Lemma permut_list_exists :
  forall  (A B : Set) (R : A -> B -> Prop) f f',  (forall t t', R t t' -> f t = f' t') ->
  forall l l', permut0 R l l' -> list_exists f l = list_exists f' l'.
Proof.
intros A B R f f' E l; induction l as [ | a l]; simpl; intros l' P;
inversion P as [ | a' b l1 l2' l2'' a_R_b Q]; subst; simpl; trivial.
rewrite list_exists_app; simpl.
rewrite (E _ _ a_R_b).
destruct (f' b); simpl.
destruct (list_exists f' l2'); simpl; trivial.
rewrite <- list_exists_app; apply IHl; trivial.
Qed.

Lemma permut_list_forall_exists :
  forall (A B A' B': Set) (R : A -> B -> Prop) (R' : A' -> B' -> Prop) f f',
  (forall ta ta' tb tb', R ta tb -> R' ta' tb' -> f ta ta' = f' tb tb') ->
  forall la la' lb lb',  permut0 R la lb -> permut0 R' la' lb' ->
  list_forall (fun t1 => list_exists (fun t2 => f t1 t2) la') la =
  list_forall (fun t1 => list_exists (fun t2 => f' t1 t2) lb') lb.
Proof.
intros A B A' B' R R' f f' E la; induction la as [ | a la];
intros la' lb lb' P P';
inversion P as [ | a' b k1 k2' k2'' a_R_b Q]; subst; simpl; trivial.
rewrite list_forall_app; simpl.
rewrite (IHla la' (k2' ++ k2'') lb' Q P').
rewrite list_forall_app; simpl.
assert (E' : forall (t : A') (t' : B'), R' t t' -> f a t = f' b t').
intros; apply E; trivial.
rewrite (@permut_list_exists _ _ R' (fun t2 : A' => f a t2) (fun t2 : B' => f' b t2) E' _ _ P').
destruct (list_exists (fun t2 : B' => f' b t2) lb'); simpl; trivial.
destruct (list_forall (fun t1 : B => list_exists (fun t2 : B' => f' t1 t2) lb') k2'); simpl; trivial.
Qed.

Section Srel.
  Variable A : Set.
  Variable eq_A : relation A.
  Variable eq_proof : equivalence _ eq_A.
  Lemma mem_permut0_mem :
    forall  l1 l2 (a:A), permut0 eq_A l1 l2 -> (mem eq_A a l1 <-> mem eq_A a l2).
  Proof.
    intros l1 l2 a H.
    assert (forall l1 l2 e, permut0 eq_A l1 l2 -> mem eq_A e l1 -> mem eq_A e l2).
    clear - eq_proof.
    intro l1; induction l1 as [ | a1 l1]; intros l2 e P e_mem_l1.
    contradiction.
    inversion P as [ | a' b l' l1' l2' a1_eq_b P' H1 H']; subst.
    destruct e_mem_l1 as [e_eq_a1 | e_mem_l1].
    rewrite <- mem_or_app.
    right; left; apply (equiv_trans _ _ eq_proof) with a1; trivial.
    apply mem_insert; apply IHl1; trivial.
    split; apply H0; trivial.
    apply permut_sym; trivial.
    intros a0 b _ _ a_eq_b; apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut0_refl : forall l, permut0 eq_A l l.
  Proof.
    intro l; apply permut_refl.
    intros a _; apply (equiv_refl _ _ eq_proof).
  Qed.

  Lemma permut0_sym : forall l1 l2, permut0 eq_A l1 l2 -> permut0 eq_A l2 l1.
  Proof.
    intros l1 l2 P; apply permut_sym; trivial.
    intros a b _ _ a_eq_b; apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut0_trans :
    forall l1 l2 l3 : list A, permut0 eq_A l1 l2 -> permut0 eq_A l2 l3 -> permut0 eq_A l1 l3.
  Proof.
  intros l1 l2 l3 P1 P2; apply permut_trans with l2; trivial.
  intros a b c _ _ _ a_eq_b b_eq_c; apply (equiv_trans _ _ eq_proof) with b; trivial.
  Qed.

  Lemma mem_morph0 :
   forall x y : A, eq_A x y ->
   forall x0 y0 : list A, permut0 eq_A x0 y0 -> (mem eq_A x x0 <-> mem eq_A y y0).
   Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P.
    rewrite (mem_permut0_mem e1 P).
    clear l1 P; assert (H : forall e1 e2, eq_A e1 e2 -> mem eq_A e1 l2 -> mem eq_A e2 l2).
    clear e1 e2 e1_eq_e2; intros e1 e2 e1_eq_e2;
    induction l2 as [ | a l]; simpl; trivial.
    intros [e1_eq_a | e1_mem_l]; [left | right; trivial].
    apply (equiv_trans _ _ eq_proof) with e1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
    apply IHl; trivial.
    split; apply H; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma cons_permut0_mem :
    forall l1 l2 e1 e2, eq_A e1 e2 -> permut0 eq_A (e1 :: l1) l2 -> mem eq_A e2 l2.
  Proof.
    intros l1 l2 e1 e2 e1_eq_e2 P.
    apply (proj1 (mem_morph0 e1_eq_e2 P)).
    left; apply (equiv_refl _ _ eq_proof).
  Qed.

 Lemma permut0_cons :
    forall e1 e2 l1 l2, eq_A e1 e2 ->
      (permut0 eq_A l1 l2 <-> permut0 eq_A (e1 :: l1) (e2 :: l2)).
  Proof.
    intros e1 e2 l1 l2 e1_eq_e2; split; intro P.
    apply (@Pcons _ _ eq_A e1 e2 l1 (@nil A) l2); trivial.
    replace l2 with (nil ++ l2); trivial;
    apply permut_cons_inside with e1 e2; trivial.
    intros a1 b1 a2 b2 _ _ _ _ a1_eq_b1 a2_eq_b1 a2_eq_b2;
    apply (equiv_trans _ _ eq_proof) with a2; trivial.
    apply (equiv_trans _ _ eq_proof) with b1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

 Lemma permut0_add_inside :
    forall e1 e2 l1 l2 l3 l4,  eq_A e1 e2 ->
      (permut0 eq_A (l1 ++ l2) (l3 ++ l4) <->
      permut0 eq_A (l1 ++ e1 :: l2) (l3 ++ e2 :: l4)).
  Proof.
  intros e1 e2 l1 l2 l3 l4 e1_eq_e2; split; intro P.
  apply permut_strong; trivial.
  apply permut_add_inside with e1 e2; trivial.
  intros a1 b1 a2 b2 _ _ _ _ a1_eq_b1 a2_eq_b1 a2_eq_b2;
  apply (equiv_trans _ _ eq_proof) with a2; trivial.
  apply (equiv_trans _ _ eq_proof) with b1; trivial.
  apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut0_cons_inside :
    forall e1 e2 l l1 l2, eq_A e1 e2 ->
      (permut0 eq_A l (l1 ++ l2) <-> permut0 eq_A (e1 :: l) (l1 ++ e2 :: l2)).
  Proof.
    intros e1 e2 l l1 l2 e1_eq_e2.
    apply (permut0_add_inside nil l l1 l2 e1_eq_e2).
  Qed.

(** Permutation is compatible with append. *)
Lemma permut0_app1 :
  forall l l1 l2, permut0 eq_A l1 l2 <-> permut0 eq_A (l ++ l1) (l ++ l2).
Proof.
intros l l1 l2; apply permut_app1.
apply eq_proof.
Qed.

Lemma permut0_app2 :
  forall l l1 l2, permut0 eq_A l1 l2 <-> permut0 eq_A (l1 ++ l) (l2 ++ l).
Proof.
intros l l1 l2; apply permut_app2.
apply eq_proof.
Qed.

End Srel.

  Add Parametric Relation (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (list A) (permut0 eq_A)
  reflexivity proved by (permut0_refl eq_proof)
    symmetry proved by (permut0_sym eq_proof)
      transitivity proved by (permut0_trans eq_proof) as LP.

Add Parametric Morphism  (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (mem eq_A)
	with signature eq_A ==> permut0 eq_A ==> iff
	as mem_morph2.
  exact (mem_morph0 eq_proof).
Qed.

  Add Parametric Morphism (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (List.cons (A:=A))
	with signature eq_A ==> permut0 eq_A ==> permut0 eq_A
	as add_A_morph.
  Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P; rewrite <- (@permut0_cons _ _ eq_proof e1 e2 l1 l2); trivial.
  Qed.

Add Parametric Morphism (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (List.app (A:=A))
	with signature permut0 eq_A ==> permut0 eq_A ==> permut0 eq_A
	as app_morph.
Proof.
intros l1 l2 P l1' l2' P'.
apply (permut0_trans eq_proof) with (l1 ++ l2').
rewrite <- permut_app1; trivial.
rewrite <- permut_app2; trivial.
Qed.

Section SRel2.
  Variable A : Set.
  Variable eq_A : relation A.
  Variable eq_proof : equivalence _ eq_A.
  Variable eq_bool : A -> A -> bool.
  Hypothesis eq_bool_ok :
    forall t1 t2, match eq_bool t1 t2 with true => eq_A t1 t2 | false => ~eq_A t1 t2 end.

Lemma ac_syntactic_aux :
 forall (l1 l2 l3 l4 : list A),
 permut0 eq_A (l1 ++ l2) (l3 ++ l4) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut0 eq_A l1 (u1 ++ u2) /\
 permut0 eq_A l2 (u3 ++ u4) /\
 permut0 eq_A l3 (u1 ++ u3) /\
 permut0 eq_A l4 (u2 ++ u4)).
Proof.
induction l1 as [ | a1 l1]; intros l2 l3 l4 P.
exists (nil : list A); exists (nil : list A); exists l3; exists l4; simpl.
repeat split.
apply (permut0_refl eq_proof).
intuition.
apply (permut0_refl eq_proof).
apply (permut0_refl eq_proof).

simpl in P.

assert (a1_in_l3l4 := @cons_permut0_mem _ _  eq_proof _ _ _ _ (equiv_refl _ _ eq_proof a1) P).
rewrite <- mem_or_app in a1_in_l3l4;
destruct a1_in_l3l4 as [a1_in_l3 | a1_in_l4].
generalize (mem_split_set _ _ eq_bool_ok _ _ a1_in_l3).
intros [a1' [l3' [l3'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l3.
rewrite app_ass in P; rewrite <- app_comm_cons in P;
rewrite <- permut0_cons_inside in P; trivial.
rewrite <- app_ass in P;
destruct (IHl1 l2 (l3' ++ l3'') l4 P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
exists (a1 :: u1); exists u2; exists u3; exists u4; repeat split; simpl; trivial.
rewrite <- permut0_cons; trivial; apply (equiv_refl _ _ eq_proof).
apply (permut0_sym eq_proof).  rewrite <- permut0_cons_inside; auto.
apply (permut0_sym eq_proof). assumption.

generalize (mem_split_set _ _ eq_bool_ok _ _ a1_in_l4).
intros [a1' [l4' [l4'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l4.
rewrite <- app_ass in P;
rewrite <- permut0_cons_inside in P; trivial.
rewrite app_ass in P;
destruct (IHl1 l2 l3 (l4' ++ l4'') P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]];
exists u1; exists (a1 :: u2); exists u3; exists u4; intuition; simpl; trivial.
rewrite <- permut0_cons_inside; trivial. constructor;assumption.
apply permut0_sym; [constructor;auto|].
rewrite <- permut0_cons_inside; trivial.
apply permut0_sym; trivial.
constructor;assumption.
constructor;assumption.
Qed.

Lemma list_permut0_app_app :
 forall l1 l2, permut0 eq_A (l1 ++ l2) (l2 ++ l1).
Proof.
intros l1 l2; apply permut_swapp;apply permut0_refl;assumption.
Qed.

Lemma ac_syntactic :
 forall (l1 l2 l3 l4 : list A),
 permut0 eq_A (l2 ++ l1) (l4 ++ l3) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut0 eq_A l1 (u1 ++ u2) /\
 permut0 eq_A l2 (u3 ++ u4) /\
 permut0 eq_A l3 (u1 ++ u3) /\
 permut0 eq_A l4 (u2 ++ u4)).
Proof.
intros l1 l2 l3 l4 P; apply ac_syntactic_aux.
apply permut0_trans with (l2 ++ l1). assumption.
apply list_permut0_app_app.
apply permut0_trans with (l4 ++ l3); trivial.
apply list_permut0_app_app.
Qed.

End SRel2.

Module Type S.

  Declare Module Import EDS : decidable_set.ES.
  Notation permut := (permut0 eq_A).

(* Theorem list_permut_refl *)
 Parameter permut_refl :
    forall (l : list A), permut l l.

 (* Theorem list_permut_sym *)
 Parameter permut_sym :
    forall l1 l2 : list A, permut l1 l2 -> permut l2 l1.

(* Theorem list_permut_trans *)
  Parameter permut_trans :
    forall l1 l2 l3 : list A, permut l1 l2 -> permut l2 l3 -> permut l1 l3.

  Hint Immediate permut_refl.
  Hint Resolve permut_sym.

(* Theorem mem_permut_mem *)
 Parameter mem_permut_mem :
    forall l1 l2 e, permut l1 l2 -> (mem eq_A e l1 <-> mem eq_A e l2).

(* Theorem cons_permut_mem *)
   Parameter cons_permut_mem :
    forall l1 l2 e1 e2, eq_A e1 e2 -> permut (e1 :: l1) l2 -> mem eq_A e2 l2.

(* Theorem permut_cons *)
  Parameter permut_cons :
    forall e1 e2 l1 l2, eq_A e1 e2 ->
      (permut l1 l2 <-> permut (e1 :: l1) (e2 :: l2)).

(* Theorem permut_add_inside *)
   Parameter permut_add_inside :
    forall e1 e2 l1 l2 l3 l4,  eq_A e1 e2 ->
      (permut (l1 ++ l2) (l3 ++ l4) <->
      permut (l1 ++ e1 :: l2) (l3 ++ e2 :: l4)).

(* Theorem permut_cons_inside *)
  Parameter permut_cons_inside :
    forall e1 e2 l l1 l2, eq_A e1 e2 ->
      (permut l (l1 ++ l2) <-> permut (e1 :: l) (l1 ++ e2 :: l2)).

(* Theorem permut_app1 *)
 Parameter permut_app1 :
  forall l l1 l2, permut l1 l2 <-> permut (l ++ l1) (l ++ l2).

(* Theorem permut_app2 *)
Parameter permut_app2 :
  forall l l1 l2, permut l1 l2 <-> permut (l1 ++ l) (l2 ++ l).

(* Theorem list_permut_app_app *)
 Parameter list_permut_app_app :
 forall l1 l2, permut (l1 ++ l2) (l2 ++ l1).

Definition permut_bool :=
              (fix permut_bool (kk1 kk2 : list A) {struct kk1} :  bool :=
               (match kk1 with
               | nil => match kk2 with nil => true | _ :: _=> false end
               | t1 :: k1 =>
                     match remove EDS.eq_bool t1 kk2 with
                           None => false
                         | Some k2 => permut_bool k1 k2 end
                         end)).

Parameter permut_bool_ok :
forall l1 l2, match permut_bool l1 l2 with true => permut l1 l2 | false => ~permut l1 l2 end.

(* Theorem ac_syntactic *)
 Parameter ac_syntactic :
 forall (l1 l2 l3 l4 : list A),
 permut (l2 ++ l1) (l4 ++ l3) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut l1 (u1 ++ u2) /\
 permut l2 (u3 ++ u4) /\
 permut l3 (u1 ++ u3) /\
 permut l4 (u2 ++ u4)).

(*  Theorem remove_is_sound *)
Parameter remove_is_sound :
  forall x l, match remove eq_bool x l with
                | None => ~mem eq_A x l
                | Some l' => permut l (x :: l')
                end.

Parameter remove_equiv_nil_2 : forall l, remove_equiv eq_bool l nil = (l,nil).

(*  Theorem remove_equiv_is_sound *)
Parameter remove_equiv_is_sound:
  forall l1 l2, match remove_equiv eq_bool l1 l2 with
  | (l1', l2') => exists l, permut l1 (l ++ l1') /\ permut l2 (l ++ l2') /\
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False)
  end.

Parameter remove_equiv_is_complete :
  forall l1 l2 l l1' l2', permut l1 (l ++ l1') -> permut l2 (l ++ l2') ->
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False) ->
    (permut (fst (remove_equiv eq_bool l1 l2)) l1' /\ permut (snd (remove_equiv eq_bool l1 l2)) l2').

Parameter remove_equiv_permut:
  forall l1 l1' l2 l2', permut l1 l1' -> permut l2 l2' ->
      permut (fst (remove_equiv eq_bool l1 l2))  (fst (remove_equiv eq_bool l1' l2')) /\
          permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1' l2')).

  Add Relation (list A) permut
  reflexivity proved by permut_refl
    symmetry proved by permut_sym
      transitivity proved by permut_trans as LP.

   Add Morphism (mem eq_A)
	with signature eq_A ==> permut ==> iff
	as mem_morph2.
 Admitted.
 Add Morphism (List.app (A:=A))
   with signature permut ==> permut ==> permut
     as app_morph.
Admitted.
Add Morphism (List.cons (A:=A))
  with signature eq_A ==> permut ==> permut
    as add_A_morph.
Admitted.
End S.

(** ** Definition of permutation over lists. *)
Module Make (EDS1 : decidable_set.ES) : S with Module EDS:= EDS1.

  Module Import EDS <: decidable_set.ES := EDS1.
  Notation permut := (permut0 eq_A).

(** ** Permutation is a equivalence relation.
      Reflexivity. *)
  Theorem permut_refl :  forall (l : list A), permut l l.
  Proof.
  intro l; apply permut_refl.
  intros a _; apply (equiv_refl _ _ eq_proof).
  Qed.

  (** Symetry. *)
  Theorem permut_sym : forall l1 l2 : list A, permut l1 l2 -> permut l2 l1.
  Proof.
  intros l1 l2 P; apply permut_sym; trivial.
  intros a b _ _ a_eq_b; apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Hint Immediate permut_refl.
  Hint Resolve permut_sym.

  (** Transitivity. *)
  Theorem permut_trans :
    forall l1 l2 l3 : list A, permut l1 l2 -> permut l2 l3 -> permut l1 l3.
  Proof.
  intros l1 l2 l3 P1 P2; apply permut_trans with l2; trivial.
  intros a b c _ _ _ a_eq_b b_eq_c; apply (equiv_trans _ _ eq_proof) with b; trivial.
  Qed.

  Add Relation (list A) permut
  reflexivity proved by permut_refl
    symmetry proved by permut_sym
      transitivity proved by permut_trans as LP.

  (** ** Compatibility Properties.
      Permutation is compatible with mem. *)
  Lemma mem_permut_mem :
    forall l1 l2 e, permut l1 l2 -> (mem eq_A e l1 <-> mem eq_A e l2).
  Proof.
    assert (forall l1 l2 e, permut l1 l2 -> mem eq_A e l1 -> mem eq_A e l2).
    intro l1; induction l1 as [ | a1 l1]; intros l2 e P e_mem_l1.
    contradiction.
    inversion P as [ | a' b l' l1' l2' a1_eq_b P' H1 H']; subst.
    destruct e_mem_l1 as [e_eq_a1 | e_mem_l1].
    rewrite <- mem_or_app.
    right; left; apply (equiv_trans _ _ eq_proof) with a1; trivial.
    apply mem_insert; apply IHl1; trivial.
    intros l1 l2 e P; split; apply H; trivial.
    apply permut_sym; trivial.
  Qed.

Lemma mem_morph :
   forall x y : EDS1.A, EDS1.eq_A x y ->
   forall x0 y0 : list EDS1.A, permut x0 y0 -> (mem EDS1.eq_A x x0 <-> mem EDS1.eq_A y y0).
   Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P.
    rewrite (mem_permut_mem e1 P).
    clear l1 P; assert (H : forall e1 e2, eq_A e1 e2 -> mem eq_A e1 l2 -> mem eq_A e2 l2).
    clear e1 e2 e1_eq_e2; intros e1 e2 e1_eq_e2;
    induction l2 as [ | a l]; simpl; trivial.
    intros [e1_eq_a | e1_mem_l]; [left | right; trivial].
    apply (equiv_trans _ _ eq_proof) with e1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
    apply IHl; trivial.
    split; apply H; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

Add Morphism (mem eq_A)
	with signature eq_A ==> permut ==> iff
	as mem_morph2.
exact mem_morph.
Qed.

  Lemma cons_permut_mem :
    forall l1 l2 e1 e2, eq_A e1 e2 -> permut (e1 :: l1) l2 -> mem eq_A e2 l2.
  Proof.
    intros l1 l2 e1 e2 e1_eq_e2 P.
    apply (proj1 (mem_morph e1_eq_e2 P)).
    left; apply (equiv_refl _ _ eq_proof).
Qed.

  (** Permutation is compatible with addition and removal of common elements *)

 Lemma permut_cons :
    forall e1 e2 l1 l2, eq_A e1 e2 ->
      (permut l1 l2 <-> permut (e1 :: l1) (e2 :: l2)).
  Proof.
    intros e1 e2 l1 l2 e1_eq_e2; split; intro P.
    apply (@Pcons _ _ eq_A e1 e2 l1 (@nil A) l2); trivial.
    replace l2 with (nil ++ l2); trivial;
    apply permut_cons_inside with e1 e2; trivial.
    intros a1 b1 a2 b2 _ _ _ _ a1_eq_b1 a2_eq_b1 a2_eq_b2;
    apply (equiv_trans _ _ eq_proof) with a2; trivial.
    apply (equiv_trans _ _ eq_proof) with b1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
     Qed.

  Add Morphism (List.cons (A:=A))
	with signature eq_A ==> permut ==> permut
	as add_A_morph.
  Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P; rewrite <- (@permut_cons e1 e2 l1 l2); trivial.
  Qed.

 Lemma permut_add_inside :
    forall e1 e2 l1 l2 l3 l4,  eq_A e1 e2 ->
      (permut (l1 ++ l2) (l3 ++ l4) <->
      permut (l1 ++ e1 :: l2) (l3 ++ e2 :: l4)).
  Proof.
  intros e1 e2 l1 l2 l3 l4 e1_eq_e2; split; intro P.
  apply permut_strong; trivial.
  apply permut_add_inside with e1 e2; trivial.
  intros a1 b1 a2 b2 _ _ _ _ a1_eq_b1 a2_eq_b1 a2_eq_b2;
  apply (equiv_trans _ _ eq_proof) with a2; trivial.
  apply (equiv_trans _ _ eq_proof) with b1; trivial.
  apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut_cons_inside :
    forall e1 e2 l l1 l2, eq_A e1 e2 ->
      (permut l (l1 ++ l2) <-> permut (e1 :: l) (l1 ++ e2 :: l2)).
  Proof.
    intros e1 e2 l l1 l2 e1_eq_e2; apply (permut_add_inside nil l l1 l2 e1_eq_e2).
  Qed.

(** Permutation is compatible with append. *)
Lemma permut_app1 :
  forall l l1 l2, permut l1 l2 <-> permut (l ++ l1) (l ++ l2).
Proof.
intros l l1 l2; apply permut_app1.
apply EDS.eq_proof.
Qed.

Lemma permut_app2 :
  forall l l1 l2, permut l1 l2 <-> permut (l1 ++ l) (l2 ++ l).
Proof.
intros l l1 l2; apply permut_app2.
apply EDS.eq_proof.
Qed.

Add Morphism (List.app (A:=A))
	with signature permut ==> permut ==> permut
	as app_morph.
Proof.
intros l1 l2 P l1' l2' P'.
apply permut_trans with (l1 ++ l2').
rewrite <- permut_app1; trivial.
rewrite <- permut_app2; trivial.
Qed.

Lemma list_permut_app_app :
 forall l1 l2, permut (l1 ++ l2) (l2 ++ l1).
Proof.
intros l1 l2; apply permut_swapp; apply permut_refl.
Qed.

Definition permut_bool :=
              (fix permut_bool (kk1 kk2 : list A) {struct kk1} :  bool :=
               (match kk1 with
               | nil => match kk2 with nil => true | _ :: _=> false end
               | t1 :: k1 =>
                     match remove EDS1.eq_bool t1 kk2 with
                           None => false
                         | Some k2 => permut_bool k1 k2 end
                         end)).

Lemma permut_bool_ok :
forall l1 l2, match permut_bool l1 l2 with true => permut l1 l2 | false => ~permut l1 l2 end.
Proof.
fix 1.
intro l1; case l1; clear l1.
intro l2; case l2; clear l2.
simpl; apply Pnil.
intros a2 l2 P; inversion P.
intros a1 l1 l2; simpl.
generalize (in_remove _ _ EDS1.eq_bool_ok a1 l2); case (remove eq_bool a1 l2).
intros k2 [a2 [l2' [l2'' [a1_eq_a2 [H H']]]]]; injection H'; clear H'; intro H'.
generalize (permut_bool_ok l1 k2); case (permut_bool l1 k2).
intro P; subst; apply Pcons; assumption.
intros not_P P'; apply not_P.
subst k2; rewrite (permut_cons_inside l1 l2' l2'' a1_eq_a2); subst l2; apply P'.
intros a1_diff_a2 P; apply a1_diff_a2.
rewrite <- (mem_permut_mem a1 P); left.
apply (equiv_refl _ _ eq_proof).
Qed.

(** ** Link with AC syntactic decomposition.*)
Lemma ac_syntactic_aux :
 forall (l1 l2 l3 l4 : list A),
 permut (l1 ++ l2) (l3 ++ l4) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut l1 (u1 ++ u2) /\
 permut l2 (u3 ++ u4) /\
 permut l3 (u1 ++ u3) /\
 permut l4 (u2 ++ u4)).
Proof.
induction l1 as [ | a1 l1]; intros l2 l3 l4 P.
exists (nil : list A); exists (nil : list A); exists l3; exists l4; simpl; intuition.

simpl in P.

assert (a1_in_l3l4 := cons_permut_mem (equiv_refl _ _ eq_proof a1) P).
rewrite <- mem_or_app in a1_in_l3l4;
destruct a1_in_l3l4 as [a1_in_l3 | a1_in_l4].
generalize (mem_split_set _ _ EDS1.eq_bool_ok _ _ a1_in_l3).
intros [a1' [l3' [l3'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l3.
rewrite app_ass in P; rewrite <- app_comm_cons in P;
rewrite <- permut_cons_inside in P; trivial.
rewrite <- app_ass in P;
destruct (IHl1 l2 (l3' ++ l3'') l4 P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
exists (a1 :: u1); exists u2; exists u3; exists u4; repeat split; simpl; trivial.
rewrite <- permut_cons; trivial; apply (equiv_refl _ _ eq_proof).
apply permut_sym; rewrite <- permut_cons_inside; auto.

generalize (mem_split_set _ _ EDS1.eq_bool_ok _ _ a1_in_l4).
intros [a1' [l4' [l4'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l4.
rewrite <- app_ass in P;
rewrite <- permut_cons_inside in P; trivial.
rewrite app_ass in P;
destruct (IHl1 l2 l3 (l4' ++ l4'') P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]];
exists u1; exists (a1 :: u2); exists u3; exists u4; intuition; simpl; trivial.
rewrite <- permut_cons_inside; trivial.
apply (equiv_refl _ _ eq_proof).
apply permut_sym;
rewrite <- permut_cons_inside; trivial;
apply permut_sym; trivial.
Qed.

Lemma ac_syntactic :
 forall (l1 l2 l3 l4 : list A),
 permut (l2 ++ l1) (l4 ++ l3) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut l1 (u1 ++ u2) /\
 permut l2 (u3 ++ u4) /\
 permut l3 (u1 ++ u3) /\
 permut l4 (u2 ++ u4)).
Proof.
intros l1 l2 l3 l4 P; apply ac_syntactic_aux.
apply permut_trans with (l2 ++ l1).
apply list_permut_app_app.
apply permut_trans with (l4 ++ l3); trivial.
apply list_permut_app_app.
Qed.

Lemma remove_is_sound :
  forall x l, match remove eq_bool x l with
                | None => ~mem eq_A x l
                | Some l' => permut l (x :: l')
                end.
Proof.
intros x l; generalize (in_remove eq_A eq_bool eq_bool_ok x l);
case (remove eq_bool x l); [ intros k [x' [l' [l'' [x_eq_x' [H1 H2]]]]] | idtac].
injection H2; clear H2; intros; subst.
apply permut_sym; rewrite <- permut_cons_inside; auto.
intro; assumption.
Qed.

Lemma remove_permut :
  forall l1 l2, permut l1 l2 -> forall a,
  match (remove eq_bool a l1) with
  | Some l =>
        match (remove eq_bool a l2) with
        | Some l' => permut l l'
        | None => False
        end
  | None => remove eq_bool a l2 = None
  end.
Proof.
intros l1 l2 P a; generalize (remove_is_sound a l1) (remove_is_sound a l2).
case (remove eq_bool a l1); case (remove eq_bool a l2).
intros l l' P1 P2.
rewrite (@permut_cons a a l' l).
apply permut_trans with l2; trivial.
apply permut_trans with l1; trivial.
apply permut_sym; trivial.
apply (equiv_refl _ _ eq_proof).
intros l P' a_not_in_l2; apply a_not_in_l2.
rewrite <- (mem_permut_mem a P).
rewrite (mem_permut_mem a P'); left; apply (equiv_refl _ _ eq_proof).
intros l a_not_in_l1 P'; assert False; [idtac | contradiction].
apply a_not_in_l1.
rewrite (mem_permut_mem a P).
rewrite (mem_permut_mem a P'); left; apply (equiv_refl _ _ eq_proof).
intros; apply refl_equal.
Defined.

Lemma remove_eq_eq :
  forall l a a', eq_A a a' ->
  match (remove eq_bool a l) with
  | Some l1 =>
        match (remove eq_bool a' l) with
        | Some l2 => l1 = l2
        | None => False
        end
  | None => remove eq_bool a' l = None
  end.
Proof.
fix 1.
intros [ | b l] a a' a_eq_a'; simpl.
apply refl_equal.
case_eq (eq_bool a b); [intro a_eq_b | intro a_diff_b].
case_eq (eq_bool a' b); [intro a'_eq_b | intro a'_diff_b].
apply refl_equal.
apply False_rec.
assert (D := eq_bool_ok a' b); rewrite a'_diff_b in D; apply D.
apply (equiv_trans _ _ eq_proof) with a.
apply (equiv_sym _ _ eq_proof); assumption.
assert (E := eq_bool_ok a b); rewrite a_eq_b in E; assumption.
case_eq (eq_bool a' b); [intro a'_eq_b | intro a'_diff_b].
apply False_rec.
assert (D := eq_bool_ok a b); rewrite a_diff_b in D; apply D.
apply (equiv_trans _ _ eq_proof) with a'.
assumption.
assert (E := eq_bool_ok a' b); rewrite a'_eq_b in E; assumption.
generalize (remove_eq_eq l _ _ a_eq_a').
case (remove eq_bool a l); case (remove eq_bool a' l); intros; subst; trivial.
discriminate.
Defined.

Lemma remove_equiv_nil_2 :
  forall l, remove_equiv eq_bool l nil = (l,nil).
Proof.
fix 1.
intros [ | a l]; simpl.
apply refl_equal.
rewrite remove_equiv_nil_2; apply refl_equal.
Qed.

Lemma remove_equiv_is_sound:
  forall l1 l2, match remove_equiv eq_bool l1 l2 with
  | (l1', l2') => exists l, permut l1 (l ++ l1') /\ permut l2 (l ++ l2') /\
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False)
  end.
Proof.
intros l1 l2;
functional induction (remove_equiv eq_bool l1 l2)
    as [ (* Case 1 *)
         | (* Case 2 *) H1 l2 e1 l1 H2 l2' H H'
         | (* Case 3 *) H1 l2 e1 l1 H2 H H' l1'' l2'' H''].
(* Case 1 *)
exists (@nil A); simpl; intuition.
(* Case 2 *)
case_eq (remove_equiv eq_bool l1 l2'); intros l1'' l2'' H''; rewrite H'' in H'.
revert H'; intros [l [P1 [P2 H']]].
exists (e1 :: l); simpl; split.
apply (proj1 (permut_cons l1 (l ++ l1'') (equiv_refl _ _ eq_proof e1))); assumption.
split; trivial.
apply permut_trans with (e1 :: l2').
assert (H''' := remove_is_sound e1 l2); rewrite H in H'''; trivial.
apply (proj1 (permut_cons l2' (l ++ l2'') (equiv_refl _ _ eq_proof e1))); assumption.
(* Case 3 *)
case_eq (remove_equiv eq_bool l1 l2); intros l1' l2' H'''; rewrite H''' in H''; injection H''; clear H''; intros; subst l1'' l2''.
rewrite H''' in H'; revert H'; intros [l [P1 [P2 H']]]; exists l; split.
rewrite <- permut_cons_inside; trivial.
apply (equiv_refl _ _ eq_proof).
split; trivial.
intros x [x_eq_e1 | x_mem_l1'] x_mem_l2'.
assert (H'' := remove_is_sound e1 l2); rewrite H in H''.
absurd (mem eq_A e1 l2); trivial.
apply (proj1 (mem_morph x_eq_e1 (permut_refl l2))).
apply (proj2 (mem_permut_mem x P2)).
rewrite <- mem_or_app; right; trivial.
apply (H' x); trivial.
Qed.

Lemma remove_equiv_is_complete :
  forall l1 l2 l l1' l2', permut l1 (l ++ l1') -> permut l2 (l ++ l2') ->
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False) ->
    (permut (fst (remove_equiv eq_bool l1 l2)) l1' /\ permut (snd (remove_equiv eq_bool l1 l2)) l2').
Proof.
intros l1 l2;
functional induction (remove_equiv eq_bool l1 l2)
    as [ (* Case 1 *)
         | (* Case 2 *) H1 l2 e1 l1 H2 l2' H H'
         | (* Case 3 *) H1 l2 e1 l1 H2 H H' l1'' l2'' H'']; intros l k1' k2' P1 P2 E.
(* Case 1 *)
revert P1 P2; simpl; case l; [idtac | intros a l'].
case k1'; [idtac | intros a1' k1''].
simpl; split; assumption.
intro P1; inversion P1.
intro P1; inversion P1.
(* Case 2 *)
case_eq (remove_equiv eq_bool l1 l2'); intros l1'' l2'' H''.
assert (e1_in_l_k1' : mem eq_A e1 (l ++ k1')).
rewrite <- (mem_permut_mem e1 P1); left; apply (equiv_refl _ _ eq_proof).
rewrite <- mem_or_app in e1_in_l_k1'; simpl.
assert (Subcase : mem eq_A e1 l -> permut l1'' k1' /\ permut l2'' k2').
intro e1_in_l; generalize (remove_is_sound e1 l); case (remove eq_bool e1 l).
intros l' P.
assert (Q1 : permut l1 (l' ++ k1')).
rewrite (permut_cons l1 (l' ++ k1') (e1 := e1) (e2 := e1)) by apply (equiv_refl _ _ eq_proof).
apply permut_trans with (l ++ k1').
exact P1.
rewrite app_comm_cons; rewrite <- permut_app2; exact P.
generalize (remove_is_sound e1 l2); rewrite H; intro P2'.
assert (Q2 : permut l2' (l' ++ k2')).
rewrite (permut_cons l2' (l' ++ k2') (e1 := e1) (e2 := e1)) by apply (equiv_refl _ _ eq_proof).
apply permut_trans with l2.
apply permut_sym; assumption.
apply permut_trans with (l ++ k2').
assumption.
rewrite app_comm_cons; rewrite <- permut_app2; exact P.
generalize (H' l' k1' k2' Q1 Q2 E).
intros [PP1 PP2]; split.
rewrite H'' in PP1; assumption.
rewrite H'' in PP2; assumption.
intro Abs; apply False_rec; apply Abs; assumption.
revert e1_in_l_k1'; intros [e1_in_l | e1_in_k1'].
apply (Subcase e1_in_l).
assert (R := remove_is_sound e1 l2); rewrite H in R.
assert (e1_in_l2 : mem eq_A e1 l2).
rewrite (mem_permut_mem e1 R); left; apply (equiv_refl _ _ eq_proof).
rewrite (mem_permut_mem e1 P2) in e1_in_l2.
rewrite <- mem_or_app in e1_in_l2.
revert e1_in_l2; intros [e1_in_l | e1_in_k2'].
apply (Subcase e1_in_l).
apply False_rec; apply (E _ e1_in_k1' e1_in_k2').
(* Case 3 *)
case_eq (remove_equiv eq_bool l1 l2); intros l1' l2' H'''.
assert (R := remove_is_sound e1 l2); rewrite H in R.
assert (e1_in_l_k1' : mem eq_A e1 (l ++ k1')).
rewrite <- (mem_permut_mem e1 P1); left; apply (equiv_refl _ _ eq_proof).
rewrite <- mem_or_app in e1_in_l_k1'.
revert e1_in_l_k1'; intros [e1_in_l | e1_in_k1'].
apply False_rec.
apply R; rewrite (mem_permut_mem e1 P2).
rewrite <- mem_or_app; left; assumption.
simpl; generalize (remove_is_sound e1 k1'); case (remove eq_bool e1 k1').
intros k' P.
assert (Q1 : permut l1 (l ++ k')).
rewrite (permut_cons l1 (l ++ k') (e1 := e1) (e2 := e1)) by apply (equiv_refl _ _ eq_proof).
apply permut_trans with (l ++ k1').
exact P1.
apply permut_trans with (l ++ e1 :: k').
rewrite <- permut_app1; assumption.
apply permut_sym; rewrite <- permut_cons_inside; [apply permut_refl | apply (equiv_refl _ _ eq_proof)].
assert (E' : forall x : EDS1.A, mem eq_A x k' -> mem eq_A x k2' -> False).
intros x x_in_k x_in_k2'; apply (E x); trivial.
rewrite (mem_permut_mem x P); right; assumption.
generalize (H' l k' k2' Q1 P2 E'); rewrite H''; simpl.
intros [H1 H2]; split; trivial.
apply permut_trans with (e1 :: k').
rewrite <- permut_cons by apply (equiv_refl _ _ eq_proof); assumption.
apply permut_sym; assumption.
intro Abs; apply False_rec; apply Abs; assumption.
Qed.

Lemma remove_equiv_permut_1 :
  forall l1 l1', permut l1 l1' ->
      forall l2, (permut (fst (remove_equiv eq_bool l1 l2)) (fst (remove_equiv eq_bool l1' l2)) /\
      permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1' l2))).
Proof.
intros l1 l1' P1 l2;
generalize (remove_equiv_is_sound l1 l2) (remove_equiv_is_sound l1' l2).
case_eq (remove_equiv eq_bool l1 l2); intros k1 k2 H1; intros [l [Q1 [Q2 H]]].
case_eq (remove_equiv eq_bool l1' l2); intros k1' k2' H1'; intros [l' [Q1' [Q2' H']]].
simpl; assert (Q1'' : permut l1 (l' ++ k1')).
apply permut_trans with l1'; trivial.
assert (R := @remove_equiv_is_complete l1 l2 l' k1' k2' Q1'' Q2' H'); rewrite H1 in R.
revert R; intros [R1 R2]; split; trivial.
Qed.

Lemma remove_equiv_permut_2:
  forall l1 l2 l2', permut l2 l2' ->
      (fst (remove_equiv eq_bool l1 l2) =  fst (remove_equiv eq_bool l1 l2') /\
          permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1 l2'))).
Proof.
fix 1.
intros [ | a1 l1] l2 l2' P.
simpl; split; [apply refl_equal | trivial].
simpl; generalize (remove_permut P a1).
case_eq (remove eq_bool a1 l2); [intro k2 | idtac]; intro H2.
case_eq (remove eq_bool a1 l2'); [intro k2' | idtac]; intro H2'.
intro P'; assert (H := remove_equiv_permut_2 l1 _ _ P'); case H; intros H' H''; split; trivial.
intro; apply False_rec; trivial.
intro H2'; rewrite H2'.
assert (H := remove_equiv_permut_2 l1 _ _ P); case H; intros H' H''; split.
revert H'; case (remove_equiv eq_bool l1 l2); intros k1 k2;
case (remove_equiv eq_bool l1 l2'); intros k1' k2'; simpl; intros; subst; trivial.
revert H''; case (remove_equiv eq_bool l1 l2); intros k1 k2;
case (remove_equiv eq_bool l1 l2'); intros k1' k2'; simpl; intros; subst; trivial.
Defined.

Lemma remove_equiv_permut:
  forall l1 l1' l2 l2', permut l1 l1' -> permut l2 l2' ->
      permut (fst (remove_equiv eq_bool l1 l2))  (fst (remove_equiv eq_bool l1' l2')) /\
          permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1' l2')).
Proof.
intros l1 l1' l2 l2' P1 P2.
generalize (remove_equiv_permut_1 P1 l2) (remove_equiv_permut_2 l1' P2).
case (remove_equiv eq_bool l1 l2); case (remove_equiv eq_bool l1' l2); case (remove_equiv eq_bool l1' l2');
simpl; intros u1 u2 u3 u4 u5 u6 [Q1 Q2] [Q3 Q4]; split.
subst; assumption.
apply permut_trans with u4; assumption.
Qed.

End Make.

(* With section instead of module, and then polymorph use
Section LP.
Variable A : Set.
Parameter eq_A_dec : forall t1 t2 : A, {t1 = t2} + {t1 <> t2}.
...
End LP.

Add Relation list list_permut
reflexivity proved by list_permut_refl
symmetry proved by list_permut_sym
transitivity proved by list_permut_trans as LP_poly.

Add Morphism In with signature  eq ==> list_permut ==> iff as in_morph_poly.
Proof.
intros; split; intros.
apply in_permut_in with x1; trivial.
apply in_permut_in with x2; trivial; apply list_permut_sym; trivial.
Qed.

Goal forall (a b:nat), list_permut (a::b::nil) (b::a::nil) ->
In a (b :: a :: nil).
intros a b P.
rewrite <- P.
left; trivial.
Qed.
*)

(*
Extract Constant eq_element_dec => eq.
Extract Constant o_element_dec => le.
Extract Constant element => int.
Extraction split_list.
Extraction partition.
Extraction NoInline partition.
Extraction quicksort.
*)

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


(** * Norm: Normalization of STLC *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Lists.List. Import ListNotations.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Hint Constructors multi.

(* Chapter written and maintained by Andrew Tolmach *)

(** This optional chapter is based on chapter 12 of _Types and
    Programming Languages_ (Pierce).  It may be useful to look at the
    two together, as that chapter includes explanations and informal
    proofs that are not repeated here.

    In this chapter, we consider another fundamental theoretical
    property of the simply typed lambda-calculus: the fact that the
    evaluation of a well-typed program is guaranteed to halt in a
    finite number of steps---i.e., every well-typed term is
    _normalizable_.

    Unlike the type-safety properties we have considered so far, the
    normalization property does not extend to full-blown programming
    languages, because these languages nearly always extend the simply
    typed lambda-calculus with constructs, such as general
    recursion (see the [MoreStlc] chapter) or recursive types, that
    can be used to write nonterminating programs.  However, the issue
    of normalization reappears at the level of _types_ when we
    consider the metatheory of polymorphic versions of the lambda
    calculus such as System F-omega: in this system, the language of
    types effectively contains a copy of the simply typed
    lambda-calculus, and the termination of the typechecking algorithm
    will hinge on the fact that a "normalization" operation on type
    expressions is guaranteed to terminate.

    Another reason for studying normalization proofs is that they are
    some of the most beautiful---and mind-blowing---mathematics to be
    found in the type theory literature, often (as here) involving the
    fundamental proof technique of _logical relations_.

    The calculus we shall consider here is the simply typed
    lambda-calculus over a single base type [bool] and with
    pairs. We'll give most details of the development for the basic
    lambda-calculus terms treating [bool] as an uninterpreted base
    type, and leave the extension to the boolean operators and pairs
    to the reader.  Even for the base calculus, normalization is not
    entirely trivial to prove, since each reduction of a term can
    duplicate redexes in subterms. *)

(** **** Exercise: 2 stars (norm_fail)  *)
(** Where do we fail if we attempt to prove normalization by a
    straightforward induction on the size of a well-typed term? *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_norm_fail : option (prod nat string) := None.
(** [] *)

(** **** Exercise: 5 stars, recommended (norm)  *)
(** The best ways to understand an intricate proof like this is
    are (1) to help fill it in and (2) to extend it.  We've left out some
    parts of the following development, including some proofs of lemmas
    and the all the cases involving products and conditionals.  Fill them
    in. *)

(* Do not modify the following line: *)
Definition manual_grade_for_norm : option (prod nat string) := None.
(** [] *)

(* ################################################################# *)
(** * Language *)

(** We begin by repeating the relevant language definition, which is
    similar to those in the [MoreStlc] chapter, plus supporting
    results including type preservation and step determinism.  (We
    won't need progress.)  You may just wish to skip down to the
    Normalization section... *)

(* ----------------------------------------------------------------- *)
(** *** Syntax and Operational Semantics *)

Inductive ty : Type :=
  | TBool : ty
  | TArrow : ty -> ty -> ty
  | TProd  : ty -> ty -> ty
.

Inductive tm : Type :=
    (* pure STLC *)
  | tvar : string -> tm
  | tapp : tm -> tm -> tm
  | tabs : string -> ty -> tm -> tm
    (* pairs *)
  | tpair : tm -> tm -> tm
  | tfst : tm -> tm
  | tsnd : tm -> tm
    (* booleans *)
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.
          (* i.e., [if t0 then t1 else t2] *)

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if beq_string x y then s else t
  | tabs y T t1 =>
      tabs y T (if beq_string x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tpair t1 t2 => tpair (subst x s t1) (subst x s t2)
  | tfst t1 => tfst (subst x s t1)
  | tsnd t1 => tsnd (subst x s t1)
  | ttrue => ttrue
  | tfalse => tfalse
  | tif t0 t1 t2 =>
      tif (subst x s t0) (subst x s t1) (subst x s t2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ----------------------------------------------------------------- *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tabs x T11 t12)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (tpair v1 v2)
  | v_true : value ttrue
  | v_false : value tfalse
.

Hint Constructors value.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tapp (tabs x T11 t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  (* pairs *)
  | ST_Pair1 : forall t1 t1' t2,
        t1 ==> t1' ->
        (tpair t1 t2) ==> (tpair t1' t2)
  | ST_Pair2 : forall v1 t2 t2',
        value v1 ->
        t2 ==> t2' ->
        (tpair v1 t2) ==> (tpair v1 t2')
  | ST_Fst : forall t1 t1',
        t1 ==> t1' ->
        (tfst t1) ==> (tfst t1')
  | ST_FstPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (tfst (tpair v1 v2)) ==> v1
  | ST_Snd : forall t1 t1',
        t1 ==> t1' ->
        (tsnd t1) ==> (tsnd t1')
  | ST_SndPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (tsnd (tpair v1 v2)) ==> v2
  (* booleans *)
  | ST_IfTrue : forall t1 t2,
        (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
        (tif tfalse t1 t2) ==> t2
  | ST_If : forall t0 t0' t1 t2,
        t0 ==> t0' ->
        (tif t0 t1 t2) ==> (tif t0' t1 t2)

where "t1 '==>' t2" := (step t1 t2).

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Lemma value__normal : forall t, value t -> step_normal_form t.
Proof with eauto.
  intros t H; induction H; intros [t' ST]; inversion ST...
Qed.

(* ----------------------------------------------------------------- *)
(** *** Typing *)

Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=
  (* Typing rules for proper terms *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (update Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (TArrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tapp t1 t2) T2
  (* pairs *)
  | T_Pair : forall Gamma t1 t2 T1 T2,
      has_type Gamma t1 T1 ->
      has_type Gamma t2 T2 ->
      has_type Gamma (tpair t1 t2) (TProd T1 T2)
  | T_Fst : forall Gamma t T1 T2,
      has_type Gamma t (TProd T1 T2) ->
      has_type Gamma (tfst t) T1
  | T_Snd : forall Gamma t T1 T2,
      has_type Gamma t (TProd T1 T2) ->
      has_type Gamma (tsnd t) T2
  (* booleans *)
  | T_True : forall Gamma,
      has_type Gamma ttrue TBool
  | T_False : forall Gamma,
      has_type Gamma tfalse TBool
  | T_If : forall Gamma t0 t1 t2 T,
      has_type Gamma t0 TBool ->
      has_type Gamma t1 T ->
      has_type Gamma t2 T ->
      has_type Gamma (tif t0 t1 t2) T
.

Hint Constructors has_type.

Hint Extern 2 (has_type _ (tapp _ _) _) => eapply T_App; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

(* ----------------------------------------------------------------- *)
(** *** Context Invariance *)

Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  (* pairs *)
  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tpair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tpair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (tfst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (tsnd t)
  (* booleans *)
  | afi_if0 : forall x t0 t1 t2,
      appears_free_in x t0 ->
      appears_free_in x (tif t0 t1 t2)
  | afi_if1 : forall x t0 t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tif t0 t1 t2)
  | afi_if2 : forall x t0 t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tif t0 t1 t2)
.

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (beq_stringP x y)...
  - (* T_Pair *)
    apply T_Pair...
  - (* T_If *)
    eapply T_If...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; inversion Hafi; subst...
  - (* T_Abs *)
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_beq_string in Hctx...
Qed.

Corollary typable_empty__closed : forall t T,
    has_type empty t T  ->
    closed t.
Proof.
  intros. unfold closed. intros x H1.
  destruct (free_in_context _ _ _ _ H1 H) as [T' C].
  inversion C.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- ([x:=v]t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tvar and tabs.
     The former aren't automatic because we must reason about how the
     variables interact. *)
  induction t;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  - (* tvar *)
    simpl. rename s into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [update Gamma x U y = Some S].  We want to
       show that [Gamma |- [x:=v]y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    unfold update, t_update in H1.
    destruct (beq_stringP x y).
    + (* x=y *)
    (* If [x = y], then we know that [U = S], and that [[x:=v]y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      subst.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      (* If [x <> y], then [Gamma y = Some S] and the substitution has no
         effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var...
  - (* tabs *)
    rename s into y. rename t into T11.
    (* If [t = tabs y T11 t0], then we know that
         [Gamma,x:U |- tabs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- [x:=v]t0 S].

       We can calculate that
         [x:=v]t = tabs y T11 (if beq_string x y then t0 else [x:=v]t0)
       And we must show that [Gamma |- [x:=v]t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_string x y then t0 else [x:=v]t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    destruct (beq_stringP x y).
    + (* x=y *)
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (beq_string y x)...
    + (* x<>y *)
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- [x:=v]t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_stringP y z)...
      subst. rewrite false_beq_string...
Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]).  We show just the interesting ones. *)
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      (* For the third case, suppose
           [t1 = tabs x T11 t12]
         and
           [t2 = v2].
         We must show that [empty |- [x:=v2]t12 : T2].
         We know by assumption that
             [empty |- tabs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  - (* T_Fst *)
    inversion HT...
  - (* T_Snd *)
    inversion HT...
Qed.

(* ----------------------------------------------------------------- *)
(** *** Determinism *)

Lemma step_deterministic :
   deterministic step.
Proof with eauto.
   unfold deterministic.
   intros t t' t'' E1 E2.
   generalize dependent t''.
   induction E1; intros t'' E2; inversion E2; subst; clear E2...
  (* ST_AppAbs *)
   - inversion H3.
   - exfalso; apply value__normal in H...
   (* ST_App1 *)
   - inversion E1.
   -  f_equal...
   - exfalso; apply value__normal in H1...
   (* ST_App2 *)
   - exfalso; apply value__normal in H3...
   - exfalso; apply value__normal in H...
   - f_equal...
   (* ST_Pair1 *)
   - f_equal...
   - exfalso; apply value__normal in H1...
   (* ST_Pair2 *)
   - exfalso; apply value__normal in H...
   - f_equal...
   (* ST_Fst *)
   - f_equal...
   - exfalso.
     inversion E1; subst.
     + apply value__normal in H0...
     + apply value__normal in H1...
   (* ST_FstPair *)
   - exfalso.
     inversion H2; subst.
     + apply value__normal in H...
     + apply value__normal in H0...
   (* ST_Snd *)
   - f_equal...
   - exfalso.
     inversion E1; subst.
     + apply value__normal in H0...
     + apply value__normal in H1...
   (* ST_SndPair *)
   - exfalso.
     inversion H2; subst.
     + apply value__normal in H...
     + apply value__normal in H0...
   - (* ST_IfTrue *)
       inversion H3.
   - (* ST_IfFalse *)
       inversion H3.
   (* ST_If *)
   - inversion E1.
   - inversion E1.
   - f_equal...
Qed.

(* ################################################################# *)
(** * Normalization *)

(** Now for the actual normalization proof.

    Our goal is to prove that every well-typed term reduces to a
    normal form.  In fact, it turns out to be convenient to prove
    something slightly stronger, namely that every well-typed term
    reduces to a _value_.  This follows from the weaker property
    anyway via Progress (why?) but otherwise we don't need Progress,
    and we didn't bother re-proving it above.

    Here's the key definition: *)

Definition halts  (t:tm) : Prop :=  exists t', t ==>* t' /\  value t'.

(** A trivial fact: *)

Lemma value_halts : forall v, value v -> halts v.
Proof.
  intros v H. unfold halts.
  exists v. split.
  apply multi_refl.
  assumption.
Qed.

(** The key issue in the normalization proof (as in many proofs by
    induction) is finding a strong enough induction hypothesis.  To
    this end, we begin by defining, for each type [T], a set [R_T] of
    closed terms of type [T].  We will specify these sets using a
    relation [R] and write [R T t] when [t] is in [R_T]. (The sets
    [R_T] are sometimes called _saturated sets_ or _reducibility
    candidates_.)

    Here is the definition of [R] for the base language:

    - [R bool t] iff [t] is a closed term of type [bool] and [t] halts
      in a value

    - [R (T1 -> T2) t] iff [t] is a closed term of type [T1 -> T2] and
      [t] halts in a value _and_ for any term [s] such that [R T1 s],
      we have [R T2 (t s)]. *)

(** This definition gives us the strengthened induction hypothesis that we
    need.  Our primary goal is to show that all _programs_ ---i.e., all
    closed terms of base type---halt.  But closed terms of base type can
    contain subterms of functional type, so we need to know something
    about these as well.  Moreover, it is not enough to know that these
    subterms halt, because the application of a normalized function to a
    normalized argument involves a substitution, which may enable more
    reduction steps.  So we need a stronger condition for terms of
    functional type: not only should they halt themselves, but, when
    applied to halting arguments, they should yield halting results.

    The form of [R] is characteristic of the _logical relations_ proof
    technique.  (Since we are just dealing with unary relations here, we
    could perhaps more properly say _logical properties_.)  If we want to
    prove some property [P] of all closed terms of type [A], we proceed by
    proving, by induction on types, that all terms of type [A] _possess_
    property [P], all terms of type [A->A] _preserve_ property [P], all
    terms of type [(A->A)->(A->A)] _preserve the property of preserving_
    property [P], and so on.  We do this by defining a family of
    properties, indexed by types.  For the base type [A], the property is
    just [P].  For functional types, it says that the function should map
    values satisfying the property at the input type to values satisfying
    the property at the output type.

    When we come to formalize the definition of [R] in Coq, we hit a
    problem.  The most obvious formulation would be as a parameterized
    Inductive proposition like this:

      Inductive R : ty -> tm -> Prop :=
      | R_bool : forall b t, has_type empty t TBool ->
                      halts t ->
                      R TBool t
      | R_arrow : forall T1 T2 t, has_type empty t (TArrow T1 T2) ->
                      halts t ->
                      (forall s, R T1 s -> R T2 (tapp t s)) ->
                      R (TArrow T1 T2) t.

    Unfortunately, Coq rejects this definition because it violates the
    _strict positivity requirement_ for inductive definitions, which says
    that the type being defined must not occur to the left of an arrow in
    the type of a constructor argument. Here, it is the third argument to
    [R_arrow], namely [(forall s, R T1 s -> R TS (tapp t s))], and
    specifically the [R T1 s] part, that violates this rule.  (The
    outermost arrows separating the constructor arguments don't count when
    applying this rule; otherwise we could never have genuinely inductive
    properties at all!)  The reason for the rule is that types defined
    with non-positive recursion can be used to build non-terminating
    functions, which as we know would be a disaster for Coq's logical
    soundness. Even though the relation we want in this case might be
    perfectly innocent, Coq still rejects it because it fails the
    positivity test.

    Fortunately, it turns out that we _can_ define [R] using a
    [Fixpoint]: *)

Fixpoint R (T:ty) (t:tm) {struct T} : Prop :=
  has_type empty t T /\ halts t /\
  (match T with
   | TBool  => True
   | TArrow T1 T2 => (forall s, R T1 s -> R T2 (tapp t s))

   (* ... edit the next line when dealing with products *)
   | TProd T1 T2 => False
   end).

(** As immediate consequences of this definition, we have that every
    element of every set [R_T] halts in a value and is closed with type
    [t] :*)

Lemma R_halts : forall {T} {t}, R T t -> halts t.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1;  assumption.
Qed.

Lemma R_typable_empty : forall {T} {t}, R T t -> has_type empty t T.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1; assumption.
Qed.

(** Now we proceed to show the main result, which is that every
    well-typed term of type [T] is an element of [R_T].  Together with
    [R_halts], that will show that every well-typed term halts in a
    value.  *)

(* ================================================================= *)
(** **  Membership in [R_T] Is Invariant Under Reduction *)

(** We start with a preliminary lemma that shows a kind of strong
    preservation property, namely that membership in [R_T] is _invariant_
    under reduction. We will need this property in both directions,
    i.e., both to show that a term in [R_T] stays in [R_T] when it takes a
    forward step, and to show that any term that ends up in [R_T] after a
    step must have been in [R_T] to begin with.

    First of all, an easy preliminary lemma. Note that in the forward
    direction the proof depends on the fact that our language is
    determinstic. This lemma might still be true for nondeterministic
    languages, but the proof would be harder! *)

Lemma step_preserves_halting : forall t t', (t ==> t') -> (halts t <-> halts t').
Proof.
 intros t t' ST.  unfold halts.
 split.
 - (* -> *)
  intros [t'' [STM V]].
  inversion STM; subst.
   exfalso.  apply value__normal in V. unfold normal_form in V. apply V. exists t'. auto.
   rewrite (step_deterministic _ _ _ ST H). exists t''. split; assumption.
 - (* <- *)
  intros [t'0 [STM V]].
  exists t'0. split; eauto.
Qed.

(** Now the main lemma, which comes in two parts, one for each
    direction.  Each proceeds by induction on the structure of the type
    [T]. In fact, this is where we make fundamental use of the
    structure of types.

    One requirement for staying in [R_T] is to stay in type [T]. In the
    forward direction, we get this from ordinary type Preservation. *)

Lemma step_preserves_R : forall T t t', (t ==> t') -> R T t -> R T t'.
Proof.
 induction T;  intros t t' E Rt; unfold R; fold R; unfold R in Rt; fold R in Rt;
               destruct Rt as [typable_empty_t [halts_t RRt]].
  (* TBool *)
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  auto.
  (* TArrow *)
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  intros.
  eapply IHT2.
  apply  ST_App1. apply E.
  apply RRt; auto.
  (* FILL IN HERE *) Admitted.

(** The generalization to multiple steps is trivial: *)

Lemma multistep_preserves_R : forall T t t',
  (t ==>* t') -> R T t -> R T t'.
Proof.
  intros T t t' STM; induction STM; intros.
  assumption.
  apply IHSTM. eapply step_preserves_R. apply H. assumption.
Qed.

(** In the reverse direction, we must add the fact that [t] has type
   [T] before stepping as an additional hypothesis. *)

Lemma step_preserves_R' : forall T t t',
  has_type empty t T -> (t ==> t') -> R T t' -> R T t.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma multistep_preserves_R' : forall T t t',
  has_type empty t T -> (t ==>* t') -> R T t' -> R T t.
Proof.
  intros T t t' HT STM.
  induction STM; intros.
    assumption.
    eapply step_preserves_R'.  assumption. apply H. apply IHSTM.
    eapply preservation;  eauto. auto.
Qed.

(* ================================================================= *)
(** ** Closed Instances of Terms of Type [t] Belong to [R_T] *)

(** Now we proceed to show that every term of type [T] belongs to
    [R_T].  Here, the induction will be on typing derivations (it would be
    surprising to see a proof about well-typed terms that did not
    somewhere involve induction on typing derivations!).  The only
    technical difficulty here is in dealing with the abstraction case.
    Since we are arguing by induction, the demonstration that a term
    [tabs x T1 t2] belongs to [R_(T1->T2)] should involve applying the
    induction hypothesis to show that [t2] belongs to [R_(T2)].  But
    [R_(T2)] is defined to be a set of _closed_ terms, while [t2] may
    contain [x] free, so this does not make sense.

    This problem is resolved by using a standard trick to suitably
    generalize the induction hypothesis: instead of proving a statement
    involving a closed term, we generalize it to cover all closed
    _instances_ of an open term [t].  Informally, the statement of the
    lemma will look like this:

    If [x1:T1,..xn:Tn |- t : T] and [v1,...,vn] are values such that
    [R T1 v1], [R T2 v2], ..., [R Tn vn], then
    [R T ([x1:=v1][x2:=v2]...[xn:=vn]t)].

    The proof will proceed by induction on the typing derivation
    [x1:T1,..xn:Tn |- t : T]; the most interesting case will be the one
    for abstraction. *)

(* ----------------------------------------------------------------- *)
(** *** Multisubstitutions, Multi-Extensions, and Instantiations *)

(** However, before we can proceed to formalize the statement and
    proof of the lemma, we'll need to build some (rather tedious)
    machinery to deal with the fact that we are performing _multiple_
    substitutions on term [t] and _multiple_ extensions of the typing
    context.  In particular, we must be precise about the order in which
    the substitutions occur and how they act on each other.  Often these
    details are simply elided in informal paper proofs, but of course Coq
    won't let us do that. Since here we are substituting closed terms, we
    don't need to worry about how one substitution might affect the term
    put in place by another.  But we still do need to worry about the
    _order_ of substitutions, because it is quite possible for the same
    identifier to appear multiple times among the [x1,...xn] with
    different associated [vi] and [Ti].

    To make everything precise, we will assume that environments are
    extended from left to right, and multiple substitutions are performed
    from right to left.  To see that this is consistent, suppose we have
    an environment written as [...,y:bool,...,y:nat,...]  and a
    corresponding term substitution written as [...[y:=(tbool
    true)]...[y:=(tnat 3)]...t].  Since environments are extended from
    left to right, the binding [y:nat] hides the binding [y:bool]; since
    substitutions are performed right to left, we do the substitution
    [y:=(tnat 3)] first, so that the substitution [y:=(tbool true)] has
    no effect. Substitution thus correctly preserves the type of the term.

    With these points in mind, the following definitions should make sense.

    A _multisubstitution_ is the result of applying a list of
    substitutions, which we call an _environment_. *)

Definition env := list (string * tm).

Fixpoint msubst (ss:env) (t:tm) {struct ss} : tm :=
match ss with
| nil => t
| ((x,s)::ss') => msubst ss' ([x:=s]t)
end.

(** We need similar machinery to talk about repeated extension of a
    typing context using a list of (identifier, type) pairs, which we
    call a _type assignment_. *)

Definition tass := list (string * ty).

Fixpoint mupdate (Gamma : context) (xts : tass) :=
  match xts with
  | nil => Gamma
  | ((x,v)::xts') => update (mupdate Gamma xts') x v
  end.

(** We will need some simple operations that work uniformly on
    environments and type assigments *)

Fixpoint lookup {X:Set} (k : string) (l : list (string * X)) {struct l}
              : option X :=
  match l with
    | nil => None
    | (j,x) :: l' =>
      if beq_string j k then Some x else lookup k l'
  end.

Fixpoint drop {X:Set} (n:string) (nxs:list (string * X)) {struct nxs}
            : list (string * X) :=
  match nxs with
    | nil => nil
    | ((n',x)::nxs') =>
        if beq_string n' n then drop n nxs'
        else (n',x)::(drop n nxs')
  end.

(** An _instantiation_ combines a type assignment and a value
    environment with the same domains, where corresponding elements are
    in R. *)

Inductive instantiation :  tass -> env -> Prop :=
| V_nil :
    instantiation nil nil
| V_cons : forall x T v c e,
    value v -> R T v ->
    instantiation c e ->
    instantiation ((x,T)::c) ((x,v)::e).

(** We now proceed to prove various properties of these definitions. *)

(* ----------------------------------------------------------------- *)
(** *** More Substitution Facts *)

(** First we need some additional lemmas on (ordinary) substitution. *)

Lemma vacuous_substitution : forall  t x,
     ~ appears_free_in x t  ->
     forall t', [x:=t']t = t.
Proof with eauto.
  (* FILL IN HERE *) Admitted.

Lemma subst_closed: forall t,
     closed t  ->
     forall x t', [x:=t']t = t.
Proof.
  intros. apply vacuous_substitution. apply H.  Qed.

Lemma subst_not_afi : forall t x v,
    closed v ->  ~ appears_free_in x ([x:=v]t).
Proof with eauto.  (* rather slow this way *)
  unfold closed, not.
  induction t; intros x v P A; simpl in A.
    - (* tvar *)
     destruct (beq_stringP x s)...
     inversion A; subst. auto.
    - (* tapp *)
     inversion A; subst...
    - (* tabs *)
     destruct (beq_stringP x s)...
     + inversion A; subst...
     + inversion A; subst...
    - (* tpair *)
     inversion A; subst...
    - (* tfst *)
     inversion A; subst...
    - (* tsnd *)
     inversion A; subst...
    - (* ttrue *)
     inversion A.
    - (* tfalse *)
     inversion A.
    - (* tif *)
     inversion A; subst...
Qed.

Lemma duplicate_subst : forall t' x t v,
  closed v -> [x:=t]([x:=v]t') = [x:=v]t'.
Proof.
  intros. eapply vacuous_substitution. apply subst_not_afi.  auto.
Qed.

Lemma swap_subst : forall t x x1 v v1,
    x <> x1 ->
    closed v -> closed v1 ->
    [x1:=v1]([x:=v]t) = [x:=v]([x1:=v1]t).
Proof with eauto.
 induction t; intros; simpl.
  - (* tvar *)
   destruct (beq_stringP x s); destruct (beq_stringP x1 s).
   + subst. exfalso...
   + subst. simpl. rewrite <- beq_string_refl. apply subst_closed...
   + subst. simpl. rewrite <- beq_string_refl. rewrite subst_closed...
   + simpl. rewrite false_beq_string... rewrite false_beq_string...
  (* FILL IN HERE *) Admitted.

(* ----------------------------------------------------------------- *)
(** *** Properties of Multi-Substitutions *)

Lemma msubst_closed: forall t, closed t -> forall ss, msubst ss t = t.
Proof.
  induction ss.
    reflexivity.
    destruct a. simpl. rewrite subst_closed; assumption.
Qed.

(** Closed environments are those that contain only closed terms. *)

Fixpoint closed_env (env:env) {struct env} :=
  match env with
  | nil => True
  | (x,t)::env' => closed t /\ closed_env env'
  end.

(** Next come a series of lemmas charcterizing how [msubst] of closed terms
    distributes over [subst] and over each term form *)

Lemma subst_msubst: forall env x v t, closed v -> closed_env env ->
    msubst env ([x:=v]t) = [x:=v](msubst (drop x env) t).
Proof.
  induction env0; intros; auto.
  destruct a. simpl.
  inversion H0. fold closed_env in H2.
  destruct (beq_stringP s x).
  - subst. rewrite duplicate_subst; auto.
  - simpl. rewrite swap_subst; eauto.
Qed.

Lemma msubst_var:  forall ss x, closed_env ss ->
   msubst ss (tvar x) =
   match lookup x ss with
   | Some t => t
   | None => tvar x
  end.
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
     simpl. destruct (beq_string s x).
      apply msubst_closed. inversion H; auto.
      apply IHss. inversion H; auto.
Qed.

Lemma msubst_abs: forall ss x T t,
  msubst ss (tabs x T t) = tabs x T (msubst (drop x ss) t).
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
      simpl. destruct (beq_string s x); simpl; auto.
Qed.

Lemma msubst_app : forall ss t1 t2, msubst ss (tapp t1 t2) = tapp (msubst ss t1) (msubst ss t2).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

(** You'll need similar functions for the other term constructors. *)

(* FILL IN HERE *)

(* ----------------------------------------------------------------- *)
(** *** Properties of Multi-Extensions *)

(** We need to connect the behavior of type assignments with that of
    their corresponding contexts. *)

Lemma mupdate_lookup : forall (c : tass) (x:string),
    lookup x c = (mupdate empty c) x.
Proof.
  induction c; intros.
    auto.
    destruct a. unfold lookup, mupdate, update, t_update. destruct (beq_string s x); auto.
Qed.

Lemma mupdate_drop : forall (c: tass) Gamma x x',
      mupdate Gamma (drop x c) x'
    = if beq_string x x' then Gamma x' else mupdate Gamma c x'.
Proof.
  induction c; intros.
  - destruct (beq_stringP x x'); auto.
  - destruct a. simpl.
    destruct (beq_stringP s x).
    + subst. rewrite IHc.
      unfold update, t_update. destruct (beq_stringP x x'); auto.
    + simpl. unfold update, t_update. destruct (beq_stringP s x'); auto.
      subst. rewrite false_beq_string; congruence.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of Instantiations *)

(** These are strightforward. *)

Lemma instantiation_domains_match: forall {c} {e},
    instantiation c e ->
    forall {x} {T},
      lookup x c = Some T -> exists t, lookup x e = Some t.
Proof.
  intros c e V. induction V; intros x0 T0 C.
    solve_by_invert.
    simpl in *.
    destruct (beq_string x x0); eauto.
Qed.

Lemma instantiation_env_closed : forall c e,
  instantiation c e -> closed_env e.
Proof.
  intros c e V; induction V; intros.
    econstructor.
    unfold closed_env. fold closed_env.
    split.  eapply typable_empty__closed. eapply R_typable_empty. eauto.
        auto.
Qed.

Lemma instantiation_R : forall c e,
    instantiation c e ->
    forall x t T,
      lookup x c = Some T ->
      lookup x e = Some t -> R T t.
Proof.
  intros c e V. induction V; intros x' t' T' G E.
    solve_by_invert.
    unfold lookup in *.  destruct (beq_string x x').
      inversion G; inversion E; subst.  auto.
      eauto.
Qed.

Lemma instantiation_drop : forall c env,
    instantiation c env ->
    forall x, instantiation (drop x c) (drop x env).
Proof.
  intros c e V. induction V.
    intros.  simpl.  constructor.
    intros. unfold drop. destruct (beq_string x x0); auto. constructor; eauto.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Congruence Lemmas on Multistep *)

(** We'll need just a few of these; add them as the demand arises. *)

Lemma multistep_App2 : forall v t t',
  value v -> (t ==>* t') -> (tapp v t) ==>* (tapp v t').
Proof.
  intros v t t' V STM. induction STM.
   apply multi_refl.
   eapply multi_step.
     apply ST_App2; eauto.  auto.
Qed.

(* FILL IN HERE *)

(* ----------------------------------------------------------------- *)
(** *** The R Lemma. *)

(** We can finally put everything together.

    The key lemma about preservation of typing under substitution can
    be lifted to multi-substitutions: *)

Lemma msubst_preserves_typing : forall c e,
     instantiation c e ->
     forall Gamma t S, has_type (mupdate Gamma c) t S ->
     has_type Gamma (msubst e t) S.
Proof.
  induction 1; intros.
    simpl in H. simpl. auto.
    simpl in H2.  simpl.
    apply IHinstantiation.
    eapply substitution_preserves_typing; eauto.
    apply (R_typable_empty H0).
Qed.

(** And at long last, the main lemma. *)

Lemma msubst_R : forall c env t T,
    has_type (mupdate empty c) t T ->
    instantiation c env ->
    R T (msubst env t).
Proof.
  intros c env0 t T HT V.
  generalize dependent env0.
  (* We need to generalize the hypothesis a bit before setting up the induction. *)
  remember (mupdate empty c) as Gamma.
  assert (forall x, Gamma x = lookup x c).
    intros. rewrite HeqGamma. rewrite mupdate_lookup. auto.
  clear HeqGamma.
  generalize dependent c.
  induction HT; intros.

  - (* T_Var *)
   rewrite H0 in H. destruct (instantiation_domains_match V H) as [t P].
   eapply instantiation_R; eauto.
   rewrite msubst_var.  rewrite P. auto. eapply instantiation_env_closed; eauto.

  - (* T_Abs *)
    rewrite msubst_abs.
    (* We'll need variants of the following fact several times, so its simplest to
       establish it just once. *)
    assert (WT: has_type empty (tabs x T11 (msubst (drop x env0) t12)) (TArrow T11 T12)).
    { eapply T_Abs. eapply msubst_preserves_typing.
      { eapply instantiation_drop; eauto. }
      eapply context_invariance.
      { apply HT. }
      intros.
      unfold update, t_update. rewrite mupdate_drop. destruct (beq_stringP x x0).
      + auto.
      + rewrite H.
        clear - c n. induction c.
        simpl.  rewrite false_beq_string; auto.
        simpl. destruct a.  unfold update, t_update.
        destruct (beq_string s x0); auto. }
    unfold R. fold R. split.
       auto.
     split. apply value_halts. apply v_abs.
     intros.
     destruct (R_halts H0) as [v [P Q]].
     pose proof (multistep_preserves_R _ _ _ P H0).
     apply multistep_preserves_R' with (msubst ((x,v)::env0) t12).
       eapply T_App. eauto.
       apply R_typable_empty; auto.
       eapply multi_trans.  eapply multistep_App2; eauto.
       eapply multi_R.
       simpl.  rewrite subst_msubst.
       eapply ST_AppAbs; eauto.
       eapply typable_empty__closed.
       apply (R_typable_empty H1).
       eapply instantiation_env_closed; eauto.
       eapply (IHHT ((x,T11)::c)).
          intros. unfold update, t_update, lookup. destruct (beq_string x x0); auto.
       constructor; auto.

  - (* T_App *)
    rewrite msubst_app.
    destruct (IHHT1 c H env0 V) as [_ [_ P1]].
    pose proof (IHHT2 c H env0 V) as P2.  fold R in P1.  auto.

  (* FILL IN HERE *) Admitted.

(* ----------------------------------------------------------------- *)
(** *** Normalization Theorem *)

(** And the final theorem: *)

Theorem normalization : forall t T, has_type empty t T -> halts t.
Proof.
  intros.
  replace t with (msubst nil t) by reflexivity.
  apply (@R_halts T).
  apply (msubst_R nil); eauto.
  eapply V_nil.
Qed.

(** $Date$ *)


From Hammer Require Import Hammer.

Set Implicit Arguments.
Unset Strict Implicit.

Generalizable Variables A B .

Require Export Coq.Classes.SetoidClass.

Require Import Coq.Logic.Decidable.

Class DecidableSetoid `(S : Setoid A) :=
setoid_decidable : forall x y : A, decidable (x == y).

Class EqDec `(S : Setoid A) :=
equiv_dec : forall x y : A, { x == y } + { x =/= y }.

Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70).

Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
match x with
| left H => @right _ _ H
| right H => @left _ _ H
end.

Require Import Coq.Program.Program.

Local Open Scope program_scope.

Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y).

Infix "=/=" := nequiv_dec (no associativity, at level 70).

Definition equiv_decb `{EqDec A} (x y : A) : bool :=
if x == y then true else false.

Definition nequiv_decb `{EqDec A} (x y : A) : bool :=
negb (equiv_decb x y).

Infix "==b" := equiv_decb (no associativity, at level 70).
Infix "<>b" := nequiv_decb (no associativity, at level 70).

Require Import Coq.Arith.Arith.

Program Instance eq_setoid A : Setoid A | 10 :=
{ equiv := eq ; setoid_equiv := eq_equivalence }.

Program Instance nat_eq_eqdec : EqDec (eq_setoid nat) :=
eq_nat_dec.

Require Import Coq.Bool.Bool.

Program Instance bool_eqdec : EqDec (eq_setoid bool) :=
bool_dec.

Program Instance unit_eqdec : EqDec (eq_setoid unit) :=
fun x y => in_left.

Next Obligation.
Proof. hammer_hook "SetoidDec" "SetoidDec.unit_eqdec".
destruct x ; destruct y.
reflexivity.
Qed.

Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B))
: EqDec (eq_setoid (prod A B)) :=
fun x y =>
let '(x1, x2) := x in
let '(y1, y2) := y in
if x1 == y1 then
if x2 == y2 then in_left
else in_right
else in_right.

Solve Obligations with unfold complement ; program_simpl.

Program Instance bool_function_eqdec `(! EqDec (eq_setoid A))
: EqDec (eq_setoid (bool -> A)) :=
fun f g =>
if f true == g true then
if f false == g false then in_left
else in_right
else in_right.

Solve Obligations with try red ; unfold complement ; program_simpl.

Next Obligation.
Proof. hammer_hook "SetoidDec" "SetoidDec.bool_function_eqdec".
extensionality x.
destruct x ; auto.
Qed.


From Coq Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.

Inductive characteristic_function_abstraction {X:Type} (P:X->Prop) (x:X) : Prop :=
  | intro_characteristic_sat: P x ->
    In (characteristic_function_abstraction P) x.

Definition characteristic_function_to_ensemble {X:Type} (P:X->Prop) : Ensemble X :=
  characteristic_function_abstraction P.

Notation "[ x : X | P ]" :=
  (characteristic_function_to_ensemble (fun x:X => P))
  (x ident).

Lemma characteristic_function_to_ensemble_is_identity:
  forall {X:Type} (P:X->Prop),
    [ x:X | P x ] = P.
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
- destruct H.
  exact H.
- constructor.
  exact H.
Qed.

(*
Definition even_example : Ensemble nat :=
  [ n:nat | exists m:nat, n=2*m ].

Lemma even_example_result: forall n:nat, In even_example n ->
  In even_example (n+2).
Proof.
intros.
destruct H.
constructor.
destruct H as [m].
exists (m + 1).
rewrite H.
From Coq Require Import Arith.
ring.
Qed.
*)