Require Import K_Syntax.
Require Import List.
Export ListNotations.

Require Import existsT.
Require Import PeanoNat.
Require Import Lia.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Lemma In_dec : forall l (a : MPropF) , (In a l) + ((In a l) -> False).
Proof.
induction l.
- right. intro. destruct H.
- intro a0. pose (IHl a0). destruct s.
  * left. apply in_cons. assumption.
  * destruct (eq_dec_form a a0).
    + subst. left. apply in_eq.
    + right. intro. inversion H.
      { apply n. assumption. }
      { apply f. assumption. }
Qed.

(* Let us prove some lemmas about remove. *)

Lemma in_not_touched_remove : forall l1 (a0 a1 : MPropF),
        In a0 l1 -> a0 <> a1 -> In a0 (remove eq_dec_form a1 l1).
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form a1 a).
  * subst. apply IHl1. inversion H. exfalso. apply H0. auto. assumption. assumption.
  * inversion H. subst. apply in_eq. apply in_cons. apply IHl1. assumption. assumption.
Qed.

Lemma remove_dist_app {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
        forall (a : A) l1 l2, (@remove A eq_dec a (l1 ++ l2)) =
                              (@remove A eq_dec a l1) ++ (@remove A eq_dec a l2).
Proof.
intros a l1. induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec a a0).
  * apply IHl1.
  * simpl. rewrite IHl1. reflexivity.
Qed.

Lemma remove_not_in_anymore : forall l (A : MPropF),
          (In A (remove eq_dec_form A l)) -> False.
Proof.
induction l.
- intros. simpl in H. inversion H.
- intros. simpl in H. destruct (eq_dec_form A a). subst. apply IHl in H. assumption.
  inversion H. apply n. symmetry. assumption. apply IHl in H0. assumption.
Qed.

Lemma in_remove_in_init : forall l A B,
    In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l.
- intros. simpl. inversion H.
- intros. destruct (eq_dec_form A a). subst. apply in_eq. apply in_cons.
  pose (IHl A B). apply i. simpl in H. destruct (eq_dec_form B a).
  * subst. assumption.
  * inversion H. exfalso. apply n. symmetry. assumption. assumption.
Qed.

Lemma remove_preserv_NoDup : forall l (A : MPropF), NoDup l -> NoDup (remove eq_dec_form A l).
Proof.
induction l.
- intros. simpl. apply NoDup_nil.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply IHl. inversion H. assumption.
  * apply NoDup_cons. intro. apply in_remove_in_init in H0. inversion H. apply H3. assumption.
    apply IHl. inversion H. assumption.
Qed.

Lemma NoDup_destr_split : forall l1 l2 (A : MPropF), NoDup (l1 ++ A :: l2) -> NoDup (l1 ++ l2).
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_l in H. inversion H. assumption.
- intros. simpl. apply NoDup_cons. intro. inversion H. subst. apply H3. apply in_app_or in H0.
  destruct H0. apply in_or_app. left. assumption. apply in_or_app. right. apply in_cons.
  assumption. simpl in H. inversion H. subst. apply IHl1 with (A:=A). assumption.
Qed.

Lemma remove_le_length : forall l (A : MPropF), length (remove eq_dec_form A l) <= length l.
Proof.
induction l.
- intros. simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply le_S. apply IHl.
  * simpl. apply le_n_S. apply IHl.
Qed.

Lemma remove_In_smaller_length : forall l (A : MPropF),
                                 In A l -> length (remove eq_dec_form A l) < length l.
Proof.
induction l.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. unfold lt. apply le_n_S. apply remove_le_length.
  * simpl. apply Lt.lt_n_S. apply IHl. inversion H. subst. exfalso. apply n. auto.
    assumption.
Qed.

Lemma double_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a l, (@remove A eq_dec a (@remove A eq_dec a l)) = (@remove A eq_dec a l).
Proof.
intros a l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a a0).
  * subst. apply IHl.
  * simpl. destruct (eq_dec a a0).
    + exfalso. apply n. assumption.
    + rewrite IHl. reflexivity.
Qed.

Lemma permut_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a0 a1 l, (@remove A eq_dec a0 (@remove A eq_dec a1 l)) =
                      (@remove A eq_dec a1 (@remove A eq_dec a0 l)).
Proof.
intros a0 a1 l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a1 a).
  * subst. simpl. destruct (eq_dec a0 a).
    + subst. reflexivity.
    + simpl. destruct (eq_dec a a). apply IHl. exfalso. apply n0. reflexivity.
  * simpl. destruct (eq_dec a0 a).
    + subst. assumption.
    + simpl. destruct (eq_dec a1 a). exfalso. apply n. assumption.
      rewrite IHl. reflexivity.
Qed.

Lemma In_remove_diff : forall l (A B : MPropF), In A (remove eq_dec_form B l) -> A <> B.
Proof.
induction l ; intros.
- intro. simpl in H. assumption.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply IHl. assumption.
  * inversion H.
    + subst. intro. apply n. symmetry. assumption.
    + apply IHl. assumption.
Qed.

(* Now we define remove_list and prove some lemmas about it. *)

Fixpoint remove_list (l1 l2: list (MPropF)) : list (MPropF) :=
match l1 with
  | [] => l2
  | h1 :: t1 => remove eq_dec_form h1 (remove_list t1 l2)
end.

Lemma remove_list_of_nil : forall (l : list (MPropF)), remove_list l nil = nil.
Proof.
induction l.
- simpl. reflexivity.
- simpl. rewrite IHl. simpl. reflexivity.
Qed.

Lemma app_remove_list : forall (l1 l2 l3 : list (MPropF)),
        remove_list (l1 ++ l2) l3 = remove_list l1 (remove_list l2 l3).
Proof.
induction l1.
- simpl. firstorder.
- induction l2.
  * intro l3. rewrite app_nil_r. simpl. reflexivity.
  * intro l3. simpl. pose (IHl1 (a0 :: l2) l3). simpl in e.
    rewrite e. reflexivity.
Qed.

Lemma remove_list_preserv_NoDup : forall l1 l2, NoDup l2 -> NoDup (remove_list l1 l2).
Proof.
induction l1.
- intros. simpl. assumption.
- intros. simpl. apply IHl1 in H. apply remove_preserv_NoDup with (A:=a) in H.
  assumption.
Qed.

Lemma remove_list_cont : forall l1 A, In A l1 -> (forall l2, In A (remove_list l1 l2) -> False).
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl in H0. apply remove_not_in_anymore in H0. assumption.
  * simpl in H0. pose (IHl1 A H1 l2). apply f. apply in_remove_in_init with (B:= a). assumption.
Qed.

Lemma remove_list_dist_app : forall (l1 l2 l3 : list (MPropF)),
        remove_list l1 (l2 ++ l3) = (remove_list l1 l2) ++ (remove_list l1 l3).
Proof.
induction l1.
- intros. simpl. reflexivity.
- simpl. intros. rewrite IHl1. simpl. rewrite remove_dist_app. reflexivity.
Qed.

Lemma permut_remove_remove_list : forall a (l1 l2 : list (MPropF)),
      remove eq_dec_form a (remove_list l1 l2) =
      remove_list l1 (remove eq_dec_form a l2).
Proof.
intros a l1. generalize dependent a. induction l1 ; simpl.
- reflexivity.
- intros. rewrite permut_remove. rewrite IHl1. reflexivity.
Qed.

Lemma swap_remove_list : forall (l1 l2 l3 : list (MPropF)),
      remove_list (l1 ++ l2) l3 = remove_list (l2 ++ l1) l3.
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_r. reflexivity.
- induction l2.
  * rewrite app_nil_l. rewrite app_nil_r. reflexivity.
  * intro l3. simpl. rewrite IHl1. simpl. rewrite permut_remove.
    rewrite <- IHl2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma redund_remove_remove_list : forall a (l1 l2 : list (MPropF)),
      remove eq_dec_form a (remove_list (remove eq_dec_form a l1) l2) =
      remove eq_dec_form a (remove_list l1 l2).
Proof.
intro a. induction l1.
- intro l2. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec_form a a0).
  * rewrite IHl1. subst. rewrite double_remove. reflexivity.
  * simpl. rewrite permut_remove. rewrite IHl1. apply permut_remove.
Qed.

Lemma redund_remove : forall (l1 l2 l3 : list (MPropF)) a,
      remove eq_dec_form a (remove_list l1 (remove_list (remove eq_dec_form a l2) l3)) =
      remove eq_dec_form a (remove_list l1 (remove_list l2 l3)).
Proof.
intros. repeat rewrite <- app_remove_list. rewrite swap_remove_list.
rewrite app_remove_list. rewrite redund_remove_remove_list. rewrite <- app_remove_list.
rewrite swap_remove_list. reflexivity.
Qed.

Lemma redund_remove_list : forall (l1 l2 l3 : list (MPropF)),
      remove_list l1 (remove_list (remove_list l1 l2) l3) = remove_list l1 (remove_list l2 l3).
Proof.
induction l1 ; intros ; simpl.
- reflexivity.
- rewrite redund_remove. rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_in_single : forall l1 a, (In a l1) -> remove_list l1 [a] = nil.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a0 a0).
    apply remove_list_of_nil. exfalso. apply n. reflexivity.
  * apply IHl1 in H0. simpl. rewrite H0. simpl. reflexivity.
Qed.

Lemma not_removed_remove_list : forall l2 l1 A, In A l2 -> (In A l1 -> False) -> In A (remove_list l1 l2).
Proof.
induction l2.
- intros. inversion H.
- induction l1.
  * intros. simpl. assumption.
  * intros. simpl. pose (in_not_touched_remove (remove_list l1 (a :: l2))). pose (i A).
    pose (i0 a0). apply i1. apply IHl1. assumption. intro. apply H0. apply in_cons. assumption.
    clear i1. clear i0. clear i. destruct (eq_dec_form A a0). intro. apply H0. subst. apply in_eq.
    assumption.
Qed.

Lemma add_remove_list_preserve_NoDup : forall (l1 l2 : list (MPropF)),
            NoDup l1 -> NoDup l2 -> NoDup (l1 ++ (remove_list l1 l2)).
Proof.
induction l1.
- intros. rewrite app_nil_l. simpl. assumption.
- intros. simpl. apply NoDup_cons.
  * intro. apply in_app_or in H1. destruct H1. inversion H. apply H4. assumption.
    apply remove_not_in_anymore in H1. assumption.
  * rewrite permut_remove_remove_list. apply IHl1. inversion H. assumption.
    apply remove_preserv_NoDup. assumption.
Qed.

Lemma remove_list_is_in : forall l1 l2 A, In A l1 -> In A (l2 ++ (remove_list l2 l1)).
Proof.
intros. pose (In_dec l2 A). destruct s.
- apply in_or_app. left. assumption.
- apply in_or_app. right. apply not_removed_remove_list ; assumption.
Qed.

Lemma In_remove_same : forall l1 l2 (A : MPropF), In A l1 ->
                remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A).
    rewrite permut_remove_remove_list. reflexivity. exfalso. apply n. reflexivity.
  * simpl. pose (IHl1 l2 A H0). rewrite e. reflexivity.
Qed.

Lemma In_remove_length_same : forall l1 l2 (A : MPropF), In A l1 ->
                length (remove_list l1 (A :: l2)) = length (remove_list l1 l2).
Proof.
intros. rewrite In_remove_same. reflexivity. assumption.
Qed.

Lemma length_le_remove_list : forall (l1 l2 : list (MPropF)), length (remove_list l1 l2) <= length l2.
Proof.
induction l1.
- intros. auto.
- intros. simpl. rewrite permut_remove_remove_list. pose (IHl1 (remove eq_dec_form a l2)).
  apply Nat.le_trans with (m:=length (remove eq_dec_form a l2)). assumption.
  apply remove_le_length.
Qed.

Lemma remove_list_singl_id_or_nil : forall l (A : MPropF), remove_list l [A] = nil \/ remove_list l [A] = [A].
Proof.
induction l.
- intros. right. auto.
- intros. pose (IHl A). destruct o. left. simpl. rewrite H. auto.
  simpl. rewrite H. destruct (eq_dec_form A a).
  * subst. left. simpl. destruct (eq_dec_form a a). reflexivity. exfalso. apply n.
    reflexivity.
  * right. simpl. destruct (eq_dec_form a A). exfalso. apply n. symmetry. assumption.
    reflexivity.
Qed.

Lemma remove_list_non_empty_inter_smaller_length : forall l2 l1 (A : MPropF),
                                 In A l1 -> In A l2 -> length (remove_list l1 l2) < length l2.
Proof.
induction l2.
- intros. inversion H0.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. rewrite In_remove_length_same. 2: assumption. unfold lt. apply le_n_S.
    apply length_le_remove_list.
  * inversion H0.
    + exfalso. apply n. symmetry. assumption.
    + assert (a :: l2 = [a] ++ l2). auto. rewrite H2. rewrite remove_list_dist_app.
      rewrite app_length. pose (remove_list_singl_id_or_nil l1 a). destruct o.
      rewrite H3. simpl. apply Nat.lt_lt_succ_r. apply IHl2 with (A:=A) ; assumption.
      rewrite H3. simpl. apply Lt.lt_n_S. apply IHl2 with (A:=A) ; assumption.
Qed.

Lemma remove_list_delete_head : forall l1 l2 l3 A, remove_list (l1 ++ A :: l2) (A :: l3) = remove_list (l1 ++ A :: l2) l3.
Proof.
induction l1 ; intros ; simpl.
- rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A). symmetry. apply permut_remove_remove_list.
  exfalso. apply n. reflexivity.
- rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_delete_head_In : forall l1 l2 A, In A l1 -> remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
intros. pose (In_split A l1 H). destruct e. destruct H0. subst. apply remove_list_delete_head.
Qed.

Lemma remove_list_in_nil : forall l1 l2 l3 A,
        remove_list l1 (l2 ++ A :: l3) = nil ->
        (existsT2 l4 l5, l1 = l4 ++ A :: l5).
Proof.
induction l1.
- intros. simpl in H. destruct l2 ; inversion H.
- induction l2.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a A).
    + subst. exists []. exists l1. auto.
    + pose (IHl1 [] (remove eq_dec_form a l3)). simpl in s. apply s in H. destruct H. destruct s0.
      exists ([a] ++ x). exists x0. subst. auto.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
    + subst. pose (IHl2 l3 A). apply s. rewrite <- permut_remove_remove_list in H. simpl. assumption.
    + pose (IHl1 [] (remove eq_dec_form a (l2 ++ A :: l3)) a0). pose (s H). repeat destruct s0.
      subst. apply IHl2 with (l3:= l3). simpl. rewrite permut_remove_remove_list.
      rewrite remove_list_delete_head in H. assumption.
Qed.

Lemma remove_list_is_nil : forall l1 l2, (remove_list l1 l2 = nil <-> (forall A, (In A l2) -> (In A l1))).
Proof.
induction l1.
- intro l2. split.
  * intros. simpl in H. rewrite <- H. assumption.
  * intros. simpl. destruct l2.
    + reflexivity.
    + exfalso. pose (H m). assert (In m (m :: l2)). apply in_eq. apply i in H0. inversion H0.
- induction l2.
  * split.
    + intros. inversion H0.
    + intros. apply remove_list_of_nil.
  * split.
    + intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
      subst. inversion H0. subst. apply in_eq. rewrite <- permut_remove_remove_list in H. simpl in IHl2.
      rewrite IHl2 in H. apply H in H1. destruct H1. subst. apply in_eq. apply in_cons. assumption.
      inversion H0. subst. apply in_cons. pose (remove_list_in_nil l1 [] (remove eq_dec_form a l2) A).
      simpl in s. apply s in H. destruct H. destruct s0. subst. apply in_or_app. right. apply in_eq.
      apply IHl2. 2: assumption. simpl. rewrite permut_remove_remove_list.
      pose (app_eq_nil (remove_list l1 [a0]) (remove_list l1 (remove eq_dec_form a l2))). simpl in a1.
      assert (H2: remove_list l1 [a0] ++ remove_list l1 (remove eq_dec_form a l2) = []).
      rewrite <- remove_list_dist_app. simpl. assumption. apply a1 in H2. destruct H2. assumption.
    + intros. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a a0).
      { subst. rewrite <- permut_remove_remove_list. simpl in IHl2. rewrite IHl2. intros.
        pose (H A). apply i. apply in_cons. assumption. }
      { assert (H1: (forall A : MPropF, In A l2 -> In A (a :: l1))). intros. apply H.
        apply in_cons. assumption. apply IHl2 in H1.
        assert (H2: a0 :: remove eq_dec_form a l2 = [a0] ++ remove eq_dec_form a l2). auto.
        rewrite H2. rewrite remove_list_dist_app. clear H2. rewrite <- permut_remove_remove_list.
        simpl in H1. rewrite H1. rewrite app_nil_r. apply remove_list_in_single. pose (H a0).
        assert (H3: In a0 (a0 :: l2)). apply in_eq. apply i in H3. inversion H3. exfalso. apply n.
        assumption. assumption. }
Qed.

Lemma remove_delete_origin : forall l1 l2 (A B : MPropF), (A <> B) ->
            length (remove eq_dec_form A (l1 ++ B :: l2)) = S (length (remove eq_dec_form A (l1 ++ l2))).
Proof.
induction l1.
- intros. repeat rewrite app_nil_l. simpl. destruct (eq_dec_form A B). exfalso. apply H. assumption.
  simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * apply IHl1. assumption.
  * simpl. apply eq_S. apply IHl1. assumption.
Qed.

Lemma keep_list_delete_head_not_origin : forall l1 l2 l3 A, ((In A l1) -> False) ->
                length (remove_list l1 (l2 ++ A :: l3)) = S (length (remove_list l1 (l2 ++ l3))).
Proof.
induction l1.
- intros. simpl. rewrite app_length. simpl. rewrite app_length. auto.
- intros. simpl. repeat rewrite remove_list_dist_app. assert (In A l1 -> False).
  intro. apply H. apply in_cons. assumption. assert (A :: l3 = [A] ++ l3).
  auto. rewrite H1. rewrite remove_list_dist_app. pose (remove_list_singl_id_or_nil l1 A).
  destruct o. exfalso. rewrite remove_list_is_nil in H2. apply H0. apply H2.
  apply in_eq. rewrite H2. apply remove_delete_origin. intro. apply H. subst. apply in_eq.
Qed.

Lemma keep_list_delete_head_not_In : forall l1 l2 A, ((In A l1) -> False) ->
                length (remove_list l1 (A :: l2)) = S (length (remove_list l1 l2)).
Proof.
intros. pose (@keep_list_delete_head_not_origin l1 [] l2 A H). repeat rewrite app_nil_l in e.
assumption.
Qed.

Lemma In_remove_In_list : forall (A B : MPropF) l, In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l ; intros.
- simpl in H. destruct H.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply in_cons. apply IHl. assumption.
  * inversion H.
    + subst. apply in_eq.
    + apply in_cons. apply IHl. assumption.
Qed.

Lemma In_remove_list_In_list : forall (A : MPropF) l1 l2, In A (remove_list l1 l2) -> In A l2.
Proof.
intro A. induction l1 ; intros.
- simpl in H. assumption.
- simpl in H. apply In_remove_In_list in H. apply IHl1. assumption.
Qed.

Lemma In_remove_list_In_list_not_In_remove_list : forall (A : MPropF) l1 l2,
            In A (remove_list l1 l2) -> (In A l2 /\ ((In A l1) -> False)).
Proof.
intro A. induction l1 ; intros.
- simpl in H. split. assumption. intro. inversion H0.
- simpl in H. split. apply In_remove_In_list in H. apply IHl1. assumption. intro.
  inversion H0.
  * subst. apply remove_not_in_anymore in H. assumption.
  * apply In_remove_In_list in H. apply IHl1 in H. destruct H. apply H2. assumption.
Qed.

Lemma remove_list_incr_decr3 : forall (l3 l2 l1 : list (MPropF)),
              (incl l1 l2) ->
              length (remove_list l2 l3) <= length (remove_list l1 l3).
Proof.
induction l3 ; intros.
- repeat rewrite remove_list_of_nil. auto.
- destruct (In_dec l2 a).
  + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
    * rewrite remove_list_delete_head_In. 2: assumption. apply IHl3 ; auto.
    * rewrite keep_list_delete_head_not_In. 2: assumption. apply Nat.le_le_succ_r.
      apply IHl3. assumption.
  + repeat rewrite keep_list_delete_head_not_In. apply le_n_S. apply IHl3 ; auto.
    intro. apply f. apply H. assumption. assumption.
Qed.

Lemma remove_list_incr_decr1 : forall (l3 l1 l2: list (MPropF)),
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              length (remove_list l2 l3) < length (remove_list l1 l3).
Proof.
induction l3.
- intros. destruct H. destruct H. destruct H1. exfalso. inversion H1.
- intros. destruct H. destruct H. destruct H1. destruct (eq_dec_form a x).
  * subst. rewrite remove_list_delete_head_In. 2: assumption.
    rewrite keep_list_delete_head_not_In. 2: assumption. unfold lt.
    apply le_n_S. apply remove_list_incr_decr3. assumption.
  * inversion H1. exfalso. apply n ; assumption.
    assert (H4: exists A : MPropF, In A l2 /\ In A l3 /\ (In A l1 -> False)).
    exists x. auto. apply IHl3 in H4. 2 : assumption. unfold lt.
    destruct (In_dec l2 a).
    + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
      { rewrite remove_list_delete_head_In. 2: assumption. apply H4. }
      { rewrite keep_list_delete_head_not_In. 2: assumption. apply le_n_S.
        unfold lt in H4. apply Le.le_Sn_le. assumption. }
    + rewrite keep_list_delete_head_not_In. 2: assumption. rewrite keep_list_delete_head_not_In.
      unfold lt in H4. apply le_n_S. assumption. intro. apply f. apply H0. assumption.
Qed.

Lemma remove_list_incr_decr2 : forall (l4 l3 l1 : list (MPropF)),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              length (remove_list l1 l4) <= length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. apply le_0_n.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (H2: In a l3). apply H1.
    apply in_eq. pose (in_split a l3 H2). repeat destruct e. destruct H3. rewrite H3.
    rewrite keep_list_delete_head_not_origin. 2: assumption. apply le_n_S. apply IHl4.
    inversion H. assumption. subst. apply NoDup_destr_split with (A:=a). assumption.
    inversion H. unfold incl. intros. subst. assert (H9 : In a0 (a :: l4)). apply in_cons.
    assumption. pose (H1 a0 H9). apply in_app_or in i. destruct i. apply in_or_app. left.
    assumption. inversion H3. subst. exfalso. apply H6. assumption. apply in_or_app. right.
    assumption.
Qed.

Lemma remove_list_incr_decr4 : forall (l4 l3 l1: list (MPropF)),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              ((incl l3 l4) -> False) ->
              (exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False)) ->
              length (remove_list l1 l4) < length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. destruct H3. destruct H3. destruct H4. pose (In_split x l3 H3).
  destruct e. destruct H6. subst. rewrite keep_list_delete_head_not_origin. 2: assumption.
  apply Nat.lt_0_succ.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
    intro. apply H2. unfold incl. intros. apply in_cons. apply H4. assumption. destruct H3.
    destruct H3. destruct H4. exists x. repeat split ; try assumption. intro. apply H5.
    apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (In a l3). apply H1.
    apply in_eq. pose (In_split a l3 H4). destruct e. destruct H5. subst.
    rewrite keep_list_delete_head_not_origin. 2 : assumption. apply Lt.lt_n_S.
    apply IHl4. inversion H. assumption. apply NoDup_destr_split with (A:=a). assumption.
    unfold incl. intros. pose (H1 a0). assert (In a0 (a :: l4)). apply in_cons. assumption.
    apply i in H6. apply in_app_or in H6. destruct H6. apply in_or_app. left. assumption.
    inversion H6. subst. inversion H. exfalso. apply H9. assumption. apply in_or_app. right.
    assumption. intro. apply H2. unfold incl. intros. apply in_app_or in H6. destruct H6.
    apply in_cons. apply H5. apply in_or_app. left. assumption. inversion H6. subst. apply in_eq.
    apply in_cons. apply H5. apply in_or_app. right. assumption.
    destruct H3. destruct H3. destruct H5. exists x1. repeat split ; try assumption.
    apply in_app_or in H3. destruct H3. apply in_or_app. left. assumption. inversion H3.
    subst. exfalso. apply H6. apply in_eq. apply in_or_app. right. assumption.
    intro. apply H6. apply in_cons. assumption.
Qed.

Lemma remove_list_incr_decr : forall (l1 l2 l3 l4 : list (MPropF)),
              (NoDup l4) ->
              (NoDup l3) ->
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              (incl l4 l3) ->
              length (remove_list l2 l4) < length (remove_list l1 l3).
Proof.
intros. unfold lt.
pose (remove_list_incr_decr2 l1 H H0 H3).
repeat destruct H1. destruct H4. destruct (In_dec l4 x).
- assert (H6: (exists A, In A l2 /\ In A l4 /\ (In A l1 -> False))).
  exists x. repeat split ; assumption. pose (@remove_list_incr_decr1 l4 l1 l2 H6 H2).
  unfold lt in l0. apply Nat.le_trans with (m:=length (remove_list l1 l4)) ; assumption.
- assert ((incl l3 l4) -> False). intros. apply f. apply H6. assumption.
  assert ((exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False))). exists x. auto.
  pose (@remove_list_incr_decr3 l4 l2 l1 H2). pose (@remove_list_incr_decr4 l4 l3 l1 H H0 H3 H6 H7).
  unfold lt in l5. apply le_n_S in l0.
  apply Nat.le_trans with (m:=S (length (remove_list l1 l4))) ; assumption.
Qed.

Lemma In_remove_list_remove_redund : forall l1 l2 a, In a l1 ->
                remove eq_dec_form a (remove_list l1 l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. inversion H.
  * subst. rewrite double_remove. reflexivity.
  * pose (IHl1 l2 a0 H0). rewrite permut_remove. rewrite e. reflexivity.
Qed.

Lemma In_matters_remove_list : forall l1 l2, (incl l1 l2 /\ incl l2 l1) -> (forall l0,
                                    remove_list l1 l0 = remove_list l2 l0).
Proof.
induction l1.
- intros. destruct H. destruct l2. auto. unfold incl in H0. pose (H0 m). assert (In m (m :: l2)).
  apply in_eq. apply i in H1. inversion H1.
- intros. destruct H. simpl. pose (H a). assert (In a (a :: l1)). apply in_eq. apply i in H1.
  apply in_split in H1. destruct H1. destruct H1. subst. destruct (In_dec l1 a).
  * rewrite In_remove_list_remove_redund. 2: assumption. apply IHl1. split. intro. intro.
    apply H. apply in_cons. assumption. intro. intro. apply H0 in H1. inversion H1. subst.
    assumption. assumption.
  * rewrite swap_remove_list. simpl. rewrite <- redund_remove_remove_list with (l1:=(x0 ++ x)).
    pose (IHl1 (remove eq_dec_form a (x0 ++ x))). rewrite e.
    auto. split. intro. intro. apply in_not_touched_remove. assert (In a0 (a :: l1)). apply in_cons.
    assumption. apply H in H2. apply in_app_or in H2. destruct H2. apply in_or_app. right. assumption.
    inversion H2. subst. exfalso. apply f. assumption. apply in_or_app. left. assumption.
    intro. subst. apply f. assumption. intro. intro. pose (In_remove_diff (x0 ++ x) H1).
    pose (In_remove_In_list a0 a (x0 ++ x) H1). assert (In a0 (x ++ a :: x0)). apply in_app_or in i0.
    destruct i0. apply in_or_app. right. apply in_cons. assumption. apply in_or_app. left. assumption.
    apply H0 in H2. inversion H2. exfalso. apply n. symmetry. assumption. assumption.
Qed.


Require Import Setoid ProofIrrelevance FunctionalExtensionality.
Require Import Common Notations.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

(**
   An equivalence class is a non-empty set of all values
   which are all equivalent to some particular value.
*)

Local Ltac apply_proof_irrelevance :=
  match goal with
    | [ |- @eq ?T _ _ ] => let T' := type of T in
                           match eval hnf in T' with
                             | Prop => apply proof_irrelevance
                           end
  end.

Local Ltac specialize_with tac fin_tac :=
  match goal with
    | [ x : ?T, H : forall _ : ?T, _ |- _ ] => specialize (H x); tac; specialize_with tac fin_tac
    | _ => fin_tac
  end.

Section EquivalenceSet.
  Variable value : Set.
  Variable equiv : value -> value -> Prop.

  (* [E] is an equivalence class if it is non-empty and if all it consists
     of all values that are equivalent to some particular value.
     Because the equivalence relation is transitive, we can encode
     this without picking a representative element by requiring that
     for every member of the class, the class consists of exactly the
     values equivalent to that member.

     We define an [EquivalenceSet] by a map [value -> bool], rather than
     [value -> Prop], so that it can live in [Set]. *)
  Record EquivalenceSet : Set := {
    InSet' : value -> bool;
    InSet : value -> Prop := (fun v => InSet' v = true);

    SetInhabited : exists v : value, InSet v;

    SetEquivalent : relation value := equiv;
    SetEquivalent_refl : Reflexive SetEquivalent;
    SetEquivalent_sym : Symmetric SetEquivalent;
    SetEquivalent_trans : Transitive SetEquivalent;

    SetElementsEquivalent : forall v, InSet v -> forall v', InSet v' -> SetEquivalent v v';
    SetContainsEquivalent : forall v, InSet v -> forall v', SetEquivalent v v' -> InSet v'
  }.
End EquivalenceSet.

Add Parametric Relation value equiv (E : @EquivalenceSet value equiv) : _ (SetEquivalent E)
  reflexivity proved by (@SetEquivalent_refl _ _ _)
  symmetry proved by (@SetEquivalent_sym _ _ _)
  transitivity proved by (@SetEquivalent_trans _ _ _)
    as SetEquivalent_rel.

Add Parametric Morphism value equiv (E : @EquivalenceSet value equiv) : (InSet E)
  with signature equiv ==> iff
    as InSet_mor.
  intros x y eqv; split; intro inc;
    eapply SetContainsEquivalent; eauto; try symmetry; eauto.
Qed.

Section equiv.
  Variable value : Set.
  Variable equiv : value -> value -> Prop.

  Hypothesis equiv_Equivalence : Equivalence equiv.

  Local Add Parametric Relation : _ equiv
    reflexivity proved by (Equivalence.equiv_reflexive _)
    symmetry proved by (Equivalence.equiv_symmetric _)
    transitivity proved by (Equivalence.equiv_transitive _)
      as equiv_equiv_rel.

  Hypotheses equiv_dec : forall v v', {equiv v v'} + {~equiv v v'}.

  Local Infix "~=" := equiv_dec.

  Local Ltac destruct_equiv :=
    repeat match goal with
             | [ |- context[?a ~= ?b] ] => destruct (a ~= b); trivial
             | [ _ : context[?a ~= ?b] |- _ ] => let H := fresh in destruct (a ~= b) as [ H | H ]; try discriminate H; trivial
           end.

  Local Ltac simpl_equiv := hnf; intros; trivial;
    repeat match goal with
             | _ => solve [ reflexivity ]
             | _ => solve [ symmetry; trivial ]
             | _ => solve [ etransitivity; eauto ]
             | _ => solve [ symmetry; etransitivity; eauto ]
             | _ => solve [ etransitivity; eauto; symmetry; eauto ]
             | [ H : false = true |- _ ] => discriminate H
             | [ H : equiv _ _ -> False |- _ ] => contradict H; trivial
             | [ H : ~ equiv _ _ |- _ ] => contradict H; trivial
             | _ => destruct_equiv
           end.

  (* The equivalence [setOf] a particular [value] is defined by the proposition that
     the elements are equivalent to that [value]. *)
  Definition setOf (v : value) : EquivalenceSet equiv.
    exists (fun v' => if v ~= v' then true else false);
      abstract (
        try exists v; repeat split; unfold InSet in *;
          simpl_equiv
      ).
  Defined.

  Lemma setOf_refl : forall v, InSet (setOf v) v.
    compute; intro; simpl_equiv.
  Qed.

  (* Two equivalence classes are the same if they share all values *)
  Definition sameSet (C C' : EquivalenceSet equiv) := forall v, (InSet C v <-> InSet C' v).

  Definition disjointSets (C C' : EquivalenceSet equiv) := forall v, ~InSet C v \/ ~InSet C' v.

  Definition differentSets (C C' : EquivalenceSet equiv) := exists v,
    (InSet C v /\ ~InSet C' v) \/
    (~InSet C v /\ InSet C' v).

  Definition notDisjointSets (C C' : EquivalenceSet equiv) := exists v, InSet C v /\ InSet C' v.

  Definition notDisjointSets' (C C' : EquivalenceSet equiv) := exists v v', InSet C v /\ InSet C' v' /\ equiv v v'.

  Lemma sameSet_refl : Reflexive sameSet.
    clear equiv_Equivalence; firstorder.
  Qed.

  Lemma sameSet_sym : Symmetric sameSet.
    clear equiv_Equivalence; firstorder.
  Qed.

  Lemma sameSet_trans : Transitive sameSet.
    clear equiv_Equivalence; firstorder.
  Qed.

  Lemma sameSet_eq (C C' : EquivalenceSet equiv) : sameSet C C' -> C = C'.
    clear equiv_Equivalence; intro H.
    cut (InSet' C = InSet' C');
      destruct C, C'; simpl;
        intros;
          unfold sameSet, proj1_sig, InSet, InSet' in *;
            simpl in *;
              repeat match goal with
                       | [ H := _ |- _ ] => subst H
                     end;
              subst;
                split_iff;
                f_equal; try apply_proof_irrelevance;
                  apply functional_extensionality_dep; intro;
                    repeat match goal with
                             | [ H : forall v, ?x v = true -> _ |- context[?x ?v] ] => specialize (H v)
                             | [ |- @eq bool ?a ?b ] => progress (destruct a; destruct b; trivial)
                             | [ H : _ |- _ ] => specialize (H (eq_refl _))
                           end;
                    assumption || symmetry; assumption.
  Qed.

  Lemma eq_sameSet (C C' : EquivalenceSet equiv) : C = C' -> sameSet C C'.
    intro; subst; apply sameSet_refl.
  Qed.

  Global Add Parametric Morphism : setOf
    with signature equiv ==> eq
      as setOf_mor.
    intros x y eqv;
      apply sameSet_eq; compute in *; intros; split; intros; simpl_equiv.
  Qed.

  Lemma setOf_eq x y : setOf x = setOf y <-> equiv x y.
    split; intro H; try apply setOf_mor; trivial.
    pose (setOf_refl x).
    pose (setOf_refl y).
    rewrite H in *;
      compute in *;
        simpl_equiv.
  Qed.

  Lemma disjointSets_differentSets (C C' : EquivalenceSet equiv) : (disjointSets C C') -> (differentSets C C').
    clear equiv_Equivalence; unfold differentSets, disjointSets; intro H.
    pose (SetInhabited C) as H'; destruct H' as [ x H' ].
    exists x; specialize (H x); tauto.
  Qed.

  Lemma notDisjointSets_sameSet (C C' : EquivalenceSet equiv) : (notDisjointSets C C') -> (sameSet C C').
    clear equiv_Equivalence; unfold notDisjointSets, sameSet; intro H; destruct H as [ x [ H0 H1 ] ]; intro v; split; intros;
      match goal with
        | [ H0 : InSet ?C ?x, H1 : InSet ?C ?y |- InSet ?C' ?x ]
          => let H := fresh in
            assert (H : equiv x y) by (apply (@SetElementsEquivalent _ _ C); assumption);
              rewrite H; assumption
      end.
  Qed.

  Lemma notDisjointSets_eq (C C' : EquivalenceSet equiv) : (notDisjointSets C C') -> C = C'.
    clear equiv_Equivalence; intro; apply sameSet_eq; apply notDisjointSets_sameSet; assumption.
  Qed.

  Lemma EquivalenceSet_forall_equiv__eq (C C' : EquivalenceSet equiv) :
    (forall v v', (InSet C v \/ InSet C' v') -> (InSet C v /\ InSet C' v' <-> equiv v v')) ->
    C' = C.
    clear equiv_Equivalence; intro H. apply sameSet_eq; unfold sameSet; intro v.
    assert (equiv v v) by reflexivity; firstorder.
  Qed.

  Lemma EquivalenceSet_forall__eq (C C' : EquivalenceSet equiv) :
    (forall v, InSet C v <-> InSet C' v) ->
    C' = C.
    clear equiv_Equivalence; intro H. apply sameSet_eq; unfold sameSet;
    firstorder.
  Qed.
End equiv.

Add Parametric Relation value equiv : _ (@sameSet value equiv)
  reflexivity proved by (@sameSet_refl _ _)
  symmetry proved by (@sameSet_sym _ _)
  transitivity proved by (@sameSet_trans _ _)
    as sameSet_mor.

Section InSet_setOf.
  Variable value : Set.
  Variable equiv : value -> value -> Prop.
  Variable C : EquivalenceSet equiv.

  Hypothesis equiv_dec : forall v v', {equiv v v'} + {~ equiv v v'}.

  Lemma InSet_setOf_eq eqv v : InSet C v -> C = setOf eqv equiv_dec v.
    intro H.
    apply sameSet_eq.
    pose (setOf eqv equiv_dec v).
    pose (setOf_refl eqv equiv_dec v).
    pose (@SetContainsEquivalent _ equiv).
    pose (@SetElementsEquivalent _ equiv).
    specialize_all_ways.
    intro; split; intro;
      eauto.
  Qed.

  Let C_Equivalence : Equivalence equiv
    := {| Equivalence_Reflexive := SetEquivalent_refl C;
          Equivalence_Symmetric := SetEquivalent_sym C;
          Equivalence_Transitive := SetEquivalent_trans C |}.

  Definition InSet_setOf_eq' : forall v, InSet C v -> C = setOf C_Equivalence equiv_dec v
    := InSet_setOf_eq C_Equivalence.
End InSet_setOf.

Ltac create_setOf_InSet :=
  repeat match goal with
           | [ H : InSet (@setOf ?v ?e ?eq ?eqdec ?val) _ |- _ ] => unique_pose (@setOf_refl v e eq eqdec val)
           | [ |- InSet (@setOf ?v ?e ?eq ?eqdec ?val) _ ] => unique_pose (@setOf_refl v e eq eqdec val)
         end.

Ltac replace_InSet := create_setOf_InSet;
  repeat match goal with
           | [ H : InSet ?C ?x, H' : InSet ?C ?x' |- _ ] => unique_pose (SetElementsEquivalent H H');
             try (clear H' || clear H) (* try, in case both appear in the conclusion *)
           | [ H : InSet ?C ?x |- InSet ?C ?x' ] => apply (SetContainsEquivalent H)
           | [ |- exists v : ?T, @?G v ] =>
             match G with
               | appcontext[InSet ?C ?v] => fail 1 (* [?v] cannot be the same as [v] above, so we fail *)
               | appcontext[InSet ?C _] => (* match an [InSet] expression that references a variable not scoped outside.
                                                This is a kludge to get the correct InSet, which matches the [exists]. *)
                 let v := fresh in let H := fresh in
                   destruct (SetInhabited C) as [ v H ]; exists v
             end
         end.

Ltac InSet2setOf eqv :=
  repeat match goal with
           | [ equiv_dec : forall v v' : _, {?equiv v v'} + {~ ?equiv v v'}, H : InSet ?C ?x |- _ ] =>
             apply (@InSet_setOf_eq _ _ C equiv_dec eqv _) in H
         end.

Ltac InSet2setOf' :=
  repeat match goal with
           | [ equiv_dec : forall v v' : _, {?equiv v v'} + {~ ?equiv v v'}, H : InSet ?C ?x |- _ ] =>
             apply (@InSet_setOf_eq' _ _ C equiv_dec _) in H
         end.

Hint Extern 1 (@eq (@EquivalenceSet _ _) _ _) => apply EquivalenceSet_forall__eq; replace_InSet.

Ltac clear_InSet' :=
  repeat match goal with
           | [ |- context[InSet] ] => fail 1
           | [ H : InSet _ _ |- _ ] => clear H
         end.

Ltac clear_InSet := replace_InSet; clear_InSet'.
(*
Section apply1.
  Variable value0 : Set.
  Variable equiv0 : value0 -> value0 -> Prop.

  Variable value' : Set.
  Variable equiv' : value' -> value' -> Prop.

  Variable f : value0 -> value'.
  Hypothesis f_mor : forall v v', equiv0 v v' -> equiv' (f v) (f v').
  Variable E0 : EquivalenceSet equiv0.

  Local Add Parametric Relation : _ equiv0
    reflexivity proved by (SetEquivalent_refl E0)
    symmetry proved by (SetEquivalent_sym E0)
    transitivity proved by (SetEquivalent_trans E0)
      as apply_equiv_rel.

  Hypothesis equiv'_refl : forall (v : value'), equiv' v v.
  Hypothesis equiv'_sym : forall (v v' : value'), equiv' v v' -> equiv' v' v.
  Hypothesis equiv'_trans : forall (v v' v'' : value'), equiv' v v' -> equiv' v' v'' -> equiv' v v''.

  Local Add Parametric Relation : _ equiv'
    reflexivity proved by equiv'_refl
    symmetry proved by equiv'_sym
    transitivity proved by equiv'_trans
      as apply_equiv'_rel.

  Hint Resolve f_mor.

  Definition apply_to_class : EquivalenceSet equiv'.
    Print EquivalenceSet.
    refine {| UnderlyingSet := (fun v => exists v0, InSet E0 v0 /\ equiv' v (f v0)) |};
      abstract (intros; try solve [ reflexivity || (symmetry; assumption) || (etransitivity; eauto) ];
        solve [ (destruct (SetInhabited E0) as [ v0 ]; exists (f v0); eexists; split; eauto; apply f_mor; reflexivity) ||
          (unfold In in *; destruct_hypotheses; repeat esplit; clear_InSet; try reflexivity; etransitivity; eauto)
        ]).
  Defined.

  Lemma apply_to_class_f_inj : forall v, InSet E0 v -> InSet apply_to_class (f v).
    compute; firstorder.
  Qed.

  Lemma apply_to_class_f_surj : forall v, InSet apply_to_class v -> exists v', equiv' v (f v') /\ InSet E0 v'.
    compute; firstorder.
  Qed.
End apply1.

Hint Resolve apply_to_class_f_inj.

Implicit Arguments apply_to_class [value0 equiv0
  value' equiv' equiv'_refl equiv'_sym equiv'_trans].

Lemma apply_to_setOf value0 equiv0 equiv0_refl equiv0_sym equiv0_trans value' equiv' equiv'_refl equiv'_sym equiv'_trans f f_mor e0 :
  @apply_to_class value0 equiv0 value' equiv' f f_mor
  (@setOf _ _ equiv0_refl equiv0_sym equiv0_trans e0)
  equiv'_refl equiv'_sym equiv'_trans
  = @setOf _ _ equiv'_refl equiv'_sym equiv'_trans (f e0).
Proof.
  apply forall__eq; intros; split; intros;
    hnf in *; destruct_hypotheses; clear_InSet; eauto.
Qed.

Section apply2.
  Variable value0 : Type.
  Variable equiv0 : value0 -> value0 -> Prop.

  Variable value1 : Type.
  Variable equiv1 : value1 -> value1 -> Prop.

  Variable value' : Type.
  Variable equiv' : value' -> value' -> Prop.

  (* Equivalence relations are reflexive, symmetric, and transitive. *)
  Hypotheses equiv'_refl : forall (v : value'), equiv' v v.
  Hypothesis equiv'_sym : forall (v v' : value'),
    equiv' v v' -> equiv' v' v.
  Hypothesis equiv'_trans : forall (v v' v'' : value'),
    equiv' v v' -> equiv' v' v'' -> equiv' v v''.

  Add Parametric Relation : _ equiv'
    reflexivity proved by equiv'_refl
    symmetry proved by equiv'_sym
    transitivity proved by equiv'_trans
      as apply2_equiv'_rel.

  Variable f : value0 -> value1 -> value'.
  Hypothesis f_mor : forall v0 v0', equiv0 v0 v0' -> forall v1 v1', equiv1 v1 v1' -> equiv' (f v0 v1) (f v0' v1').

  Variable E0 : EquivalenceSet equiv0.
  Variable E1 : EquivalenceSet equiv1.

  Local Add Parametric Relation : _ equiv0
    reflexivity proved by (equiv_refl E0)
    symmetry proved by (equiv_sym E0)
    transitivity proved by (equiv_trans E0)
      as apply2_equiv0_rel.

  Local Add Parametric Relation : _ equiv1
    reflexivity proved by (equiv_refl E1)
    symmetry proved by (equiv_sym E1)
    transitivity proved by (equiv_trans E1)
      as apply2_equiv1_rel.

  Definition apply2_to_class : EquivalenceSet equiv'.
    refine {| UnderlyingSet := (fun v => exists v0 v1, InSet E0 v0 /\ InSet E1 v1 /\ equiv' v (f v0 v1)) |};
      abstract (intros; try solve [ reflexivity || (symmetry; assumption) || (etransitivity; eauto) ];
        solve [
          (destruct (SetInhabited E0) as [ v0 ], (SetInhabited E1) as [ v1 ]; exists (f v0 v1); repeat eexists; eauto) ||
            (unfold In in *; destruct_hypotheses; repeat esplit; clear_InSet; try reflexivity; etransitivity; eauto)
        ]).
  Defined.

  Lemma apply2_to_class_f_inj : forall v0 v1, InSet E0 v0 -> InSet E1 v1 -> InSet apply2_to_class (f v0 v1).
    compute; firstorder.
  Qed.

  Lemma apply2_to_class_f_surj : forall v, InSet apply2_to_class v -> exists v0 v1, equiv' v (f v0 v1) /\ InSet E0 v0 /\ InSet E1 v1.
    compute; firstorder.
  Qed.
End apply2.

Hint Resolve apply2_to_class_f_inj.

Implicit Arguments apply2_to_class [value0 equiv0
  value1 equiv1
  value' equiv' equiv'_refl equiv'_sym equiv'_trans].

Lemma apply2_to_setOf
  value0 equiv0 equiv0_refl equiv0_sym equiv0_trans
  value1 equiv1 equiv1_refl equiv1_sym equiv1_trans
  value' equiv' equiv'_refl equiv'_sym equiv'_trans
  f f_mor e0 e1 :
  @apply2_to_class value0 equiv0 value1 equiv1 value' equiv'
  equiv'_refl equiv'_sym equiv'_trans
  f f_mor
  (@setOf _ _ equiv0_refl equiv0_sym equiv0_trans e0)
  (@setOf _ _ equiv1_refl equiv1_sym equiv1_trans e1)
  = @setOf _ _ equiv'_refl equiv'_sym equiv'_trans (f e0 e1).
Proof.
  apply forall__eq; intros; split; intros;
    hnf in *; destruct_hypotheses;
      repeat (clear_InSet; eexists; repeat split);
      clear_InSet; eauto; try reflexivity.
Qed.
*)

Section description.
  (** Can be imported from Coq.Logic.ClassicalDescription,
      Coq.Logic.ClassicalEpsilon, Coq.Logic.ConstructiveEpsilon,
      Coq.Logic.Epsilon, Coq.Logic.IndefiniteDescription, or, for the
      axiom, Coq.Logic.Description *)

  Hypothesis constructive_definite_description :
    forall (A : Type) (P : A->Prop),
      (exists! x, P x) -> { x : A | P x }.

  Variable T : Set.
  Hypothesis eq_dec : forall v v' : T, {v = v'} + {v <> v'}.

  Definition EquivalenceSet_eq_lift
  : EquivalenceSet (@eq T) -> T.
    intro x.
    cut (exists! u, InSet x u).
    - apply constructive_definite_description.
    - destruct (SetInhabited x) as [u H].
      exists u.
      abstract (
          split; [ exact H
                 | intros; apply (@SetElementsEquivalent _ _ x); assumption ]
        ).
  Defined.

  Definition EquivalenceSet_eq_proj
  : T -> EquivalenceSet (@eq T).
    apply setOf; try assumption; abstract typeclasses eauto.
  Defined.

  Lemma EquivalenceSet_eq_iso1
  : forall x, EquivalenceSet_eq_lift (EquivalenceSet_eq_proj x) = x.
    intros.
    expand.
    repeat match goal with
             | _ => progress intuition
             | _ => intro
             | [ |- appcontext[match ?E with _ => _ end] ] => case E
             | [ H : appcontext[match ?E with _ => _ end] |- _ ] => destruct E
             | [ H : _ |- _ ] => solve [ inversion H ]
             | _ => progress (hnf in *; simpl in *; idtac)
           end.
  Qed.

  Lemma EquivalenceSet_eq_iso2
  : forall x, EquivalenceSet_eq_proj (EquivalenceSet_eq_lift x) = x.
    intros.
    apply sameSet_eq; simpl.
    split;
      intros;
      simpl in *;
      subst;
      hnf;
      unfold EquivalenceSet_eq_lift;
      hnf in *;
      simpl in *;
      repeat match goal with
               | _ => progress intuition
               | _ => intro
               | [ |- appcontext[match ?E with _ => _ end] ] => case E
               | [ H : appcontext[match ?E with _ => _ end] |- _ ] => destruct E
               | [ H : _ |- _ ] => solve [ inversion H ]
               | _ => progress unfold EquivalenceSet_eq_lift
               | _ => progress (hnf in *; simpl in *; idtac)
               | _ => progress subst
               | [ H : _, H' : _ |- _ ] => unique_pose (SetElementsEquivalent H H')
             end.
  Qed.
End description.


From Hammer Require Import Hammer Reconstr.

Require Import Arith.

Lemma lem_1 : le 1 2.
Proof.
  hammer_hook "arith" "arith.lem_1".
  scrush.
Qed.

Lemma lem_2 : forall n : nat, Nat.Odd n \/ Nat.Odd (n + 1).
Proof.
  hammer_hook "arith" "arith.lem_2".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.Even_or_Odd, @Coq.Arith.PeanoNat.Nat.add_1_r, @Coq.Arith.PeanoNat.Nat.Odd_succ) Reconstr.Empty.
Qed.

Lemma lem_2_1 : forall n : nat, Nat.Even n \/ Nat.Even (n + 1).
Proof.
  hammer_hook "arith" "arith.lem_2_1".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.Even_or_Odd, @Coq.Arith.PeanoNat.Nat.add_1_r, @Coq.Arith.PeanoNat.Nat.Even_succ) Reconstr.Empty.
Qed.

Lemma lem_3 : le 2 3.
Proof.
  hammer_hook "arith" "arith.lem_2".
  scrush.
Qed.

Lemma lem_4 : le 3 10.
Proof.
  hammer_hook "arith" "arith.lem_4".
  scrush.
Qed.

Lemma mult_1 : forall m n k : nat, m * n + k = k + n * m.
Proof.
  hammer_hook "arith" "arith.mult_1".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.add_comm, @Coq.Arith.PeanoNat.Nat.mul_comm) Reconstr.Empty.
Qed.

Lemma lem_rew : forall m n : nat, 1 + n + m + 1 = m + 2 + n.
Proof.
  hammer_hook "arith" "arith.lem_rew".
  Reconstr.reasy (@Coq.Arith.Plus.plus_Snm_nSm, @Coq.Arith.PeanoNat.Nat.add_assoc, @Coq.Arith.PeanoNat.Nat.add_1_r, @Coq.Init.Peano.plus_n_Sm, @Coq.Arith.PeanoNat.Nat.add_1_l, @Coq.Arith.PeanoNat.Nat.add_comm) (@Coq.Arith.PeanoNat.Nat.b2n).
Qed.

Lemma lem_pow : forall n : nat, 3 * 3 ^ n = 3 ^ (n + 1).
Proof.
  hammer_hook "arith" "arith.lem_pow".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.pow_succ_r', @Coq.Arith.PeanoNat.Nat.add_1_r) Reconstr.Empty.
Qed.

Lemma lem_pow' : forall n m : nat, m * m ^ n = m ^ (n + 1).
Proof.
  hammer_hook "arith" "arith.lem_pow'".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.le_0_l, @Coq.Arith.PeanoNat.Nat.pow_succ_r, @Coq.Arith.PeanoNat.Nat.add_1_r) Reconstr.Empty.
Qed.

Lemma le_minusni_n : forall n i:nat, i <= n -> n - i <= n.
Proof.
  hammer_hook "arith" "arith.lem_minusni_n".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.le_sub_l) Reconstr.Empty.
Qed.

Lemma even_odd_cor :
  forall n:nat, exists p : nat, n = (2 * p) \/ n = S (2 * p).
Proof.
  induction n; sauto.
  - hammer_hook "arith" "arith.even_odd_cor.subgoal_1".
    Reconstr.rcrush (@Coq.Arith.PeanoNat.Nat.add_0_l) Reconstr.Empty.
  - hammer_hook "arith" "arith.even_odd_cor.subgoal_2".
    exists (S p).
    Reconstr.rsimple (Coq.Arith.PeanoNat.Nat.add_succ_l, Coq.Arith.PeanoNat.Nat.add_0_r, Coq.Init.Peano.plus_n_Sm) Reconstr.Empty.
Qed.

Lemma le_double : forall m n:nat, 2 * m <= 2 * n -> m <= n.
Proof.
  hammer_hook "arith" "arith.le_double".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.mul_le_mono_pos_l, @Coq.Arith.PeanoNat.Nat.lt_0_succ) Reconstr.Empty.
Qed.

Lemma le_mul : forall m n k:nat, k > 0 -> k * m <= k * n -> m <= n.
Proof.
  hammer_hook "arith" "arith.le_mul".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.mul_le_mono_pos_l) (@Coq.Init.Peano.gt).
Qed.

Lemma lem_lt_le_trans : forall m n, m + 1 > m - n.
Proof.
  hammer_hook "arith" "arith.lem_lt_le_trans".
  Reconstr.rsimple (@Coq.Arith.PeanoNat.Nat.sub_0_le, @Coq.Arith.PeanoNat.Nat.lt_succ_r, @Coq.Arith.PeanoNat.Nat.le_sub_l, @Coq.Arith.PeanoNat.Nat.le_ge_cases, @Coq.Arith.PeanoNat.Nat.add_1_r, @Coq.Arith.PeanoNat.Nat.sub_succ_l) (@Coq.Init.Peano.gt, @Coq.Init.Peano.lt).
Qed.

Lemma leb_compare2 : forall m n : nat,
                      PeanoNat.Nat.leb n m = true <->
                      (PeanoNat.Nat.compare n m = Lt \/ PeanoNat.Nat.compare n m = Eq).
Proof.
  hammer_hook "arith" "arith.leb_compare2".
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.lt_eq_cases, @Coq.Arith.PeanoNat.Nat.compare_refl, @Coq.Arith.Compare_dec.leb_compare, @Coq.Arith.Compare_dec.leb_complete, @Coq.Arith.Compare_dec.nat_compare_eq, @Coq.Arith.Compare_dec.nat_compare_lt, @Coq.Arith.PeanoNat.Nat.leb_refl) Reconstr.Empty.
Qed.

Lemma lem_arith_0 : forall m n, (m + n) * (m + n) = m * m + 2 * m * n + n * n.
Proof.
  hammer_hook "arith" "arith.lem_arith_0".
  sauto; eauto with arith.
Qed.

Lemma lem_arith_1 : forall m n, (m + n) * (n + m) = m * m + 2 * m * n + n * n.
Proof.
  hammer_hook "arith" "arith.lem_arith_1".
  sauto.
  rewrite Arith.PeanoNat.Nat.mul_comm.
  rewrite Arith.PeanoNat.Nat.mul_comm.
  Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.add_assoc, @Coq.Arith.PeanoNat.Nat.add_comm, @Coq.Arith.PeanoNat.Nat.add_shuffle0) Reconstr.Empty.
Qed.

Lemma lem_arith_2 : forall m n, (m + n)^2 = m^2 + 2 * m * n + n^2.
Proof.
  hammer_hook "arith" "arith.lem_arith_2".
  sauto; eauto with arith.
Qed.

Lemma lem_arith_3 : forall m n, (m + n)^3 = m^3 + 3 * m^2 * n + 3 * m * n^2 + n^3.
Proof.
  hammer_hook "arith" "arith.lem_arith_3".
  sauto; ring.
Qed.

Lemma lem_arith_4 : forall m n, (m + n)^4 = m^4 + 4 * m^3 * n + 6 * m^2 * n^2 + 4 * m * n^3 + n^4.
Proof.
  hammer_hook "arith" "arith.lem_arith_4".
  sauto; ring.
Qed.


Require Import Arith List.
Require Import Max.

Set Implicit Arguments.

(** * Some prelimiary set-up of lists at [Type] level *)

Section listT.
  Variable T : Type.

  Inductive listT : Type :=
    | nilT : listT
    | consT : T -> listT -> listT.

  Fixpoint appT (ls1 ls2 : listT) {struct ls1} : listT :=
    match ls1 with
      | nilT => ls2
      | consT x ls1' => consT x (appT ls1' ls2)
    end.

  Section listF.
    Variable f : T -> Type.

    Fixpoint listF (ts : listT) : Type :=
      match ts with
	| nilT => unit
	| consT t ts' => prodT (f t) (listF ts')
      end.

    Definition nilF : listF nilT := tt.
    Definition consF (x : T) (ts : listT) (v : f x) (ls : listF ts) : listF (consT x ts) :=
      pairT v ls.

    Definition headF (x : T) (ts : listT) (ls : listF (consT x ts)) : f x :=
      fstT ls.
    Definition tailF (x : T) (ts : listT) (ls : listF (consT x ts)) : listF ts :=
      sndT ls.
  End listF.
End listT.

Implicit Arguments nilT [T].
Implicit Arguments nilF [T f].
Implicit Arguments consF [T f x ts].
Implicit Arguments headF [T f x ts].
Implicit Arguments tailF [T f x ts].

(** * A reflective representation of simple inductive types *)

Inductive argument : Type :=
  | Self : argument
  | Other : Type -> argument.

Definition constructor := listT argument.

Section constructor.
  Variable self : Type.

  Definition interp_argument (a : argument) : Type :=
    match a with
      | Self => self
      | Other T => T
    end.

  Fixpoint argify (args: listT argument) (T : Type) {struct args} : Type :=
    match args with
      | nilT => T
      | consT t args' => interp_argument t -> argify args' T
    end.

  Fixpoint argApply (args : listT argument) (T : Type) {struct args}
    : argify args T -> listF interp_argument args -> T :=
    match args return (argify args T -> listF interp_argument args -> T) with
      | nilT => fun T' _ => T'
      | consT t args' => fun T' vals => argApply args' T (T' (headF vals)) (tailF vals)
    end.

  Definition constructorTy (con : constructor) : Type :=
    argify con self.

  Variable P : self -> Type.

  Fixpoint constructorIH (con : constructor) {struct con} : constructorTy con -> Type :=
    match con return (constructorTy con -> Type) with
      | nilT => fun v => P v
      | consT Self con' => fun T =>
	forall (x : self), P x -> constructorIH con' (T x)
      | consT (Other T') con' => fun T =>
	forall (x : T'), constructorIH con' (T x)
    end.

  Fixpoint rect (cons : listT constructor) : listF constructorTy cons -> Type :=
    match cons return (listF constructorTy cons -> Type) with
      | nilT => fun _ => forall (x : self), P x
      | consT con cons' => fun cvals =>
	constructorIH con (headF cvals) -> rect cons' (tailF cvals)
    end.
End constructor.

(** * Examples using these functions *)

Eval compute in interp_argument nat Self.
Eval compute in interp_argument nat (Other bool).

Eval compute in argify nat (consT Self (consT (Other bool) nilT)) nat.

Eval compute in argApply nat (consT Self (consT (Other bool) nilT)) nat
  (fun n b => if b then n else S n)
  (consF (f := interp_argument nat) (x := Self) O
    (consF (f := interp_argument nat) (x := Other bool) true nilF)).

Eval compute in constructorTy nat (consT Self (consT (Other bool) nilT)).

Definition O_con : constructor := nilT.
Definition S_con : constructor := consT Self nilT.

Eval simpl in constructorIH (fun n => n = n) O_con O.
Eval simpl in constructorIH (fun n => n = n) S_con S.

Definition nil_con : constructor := nilT.
Definition cons_con : constructor := consT (Other nat) (consT Self nilT).

Eval simpl in constructorIH (fun ls => ls = ls) nil_con (@nil nat).
Eval simpl in constructorIH (fun ls => ls = ls) cons_con (@cons nat).

Definition nat_conTypes := consT O_con (consT S_con nilT).
Definition nat_cons : listF (constructorTy nat) nat_conTypes :=
  consF (f := constructorTy nat) (x := O_con) O
  (consF (f := constructorTy nat) (x := S_con) S nilF).

Eval simpl in rect (fun n => n = n) nat_conTypes nat_cons.

(** * Reflected inductive types and examples *)

Record inductive : Type := Ind {
  indConTypes : listT constructor;
  indSelf : Type;
  indCons : listF (constructorTy indSelf) indConTypes;
  indRec : forall (P : indSelf -> Type), rect P indConTypes indCons
}.

Print bool.

Definition boolInd : inductive :=
  Ind
  (consT nilT
    (consT nilT
      nilT))
  (indSelf := bool)
  (consF (f := constructorTy bool) (x := nilT) true
    (consF (f := constructorTy bool) (x := nilT) false nilF))
  bool_rect.

Definition natInd : inductive :=
  Ind
  (consT nilT
    (consT (consT Self nilT)
      nilT))
  (indSelf := nat)
  (consF (f := constructorTy nat) (x := nilT) O
    (consF (f := constructorTy nat) (x := consT Self nilT) S nilF))
  nat_rect.

Definition natListInd : inductive :=
  Ind
  (consT nilT
    (consT (consT (Other nat) (consT Self nilT))
      nilT))
  (indSelf := list nat)
  (consF (f := constructorTy (list nat)) (x := nilT) (@nil nat)
    (consF (f := constructorTy (list nat)) (x := consT (Other nat) (consT Self nilT)) (@cons nat) nilF))
  (@list_rect nat).

Inductive natTree : Set :=
  | Leaf : nat -> natTree
  | Node : natTree -> natTree -> natTree.

Definition natTreeInd : inductive :=
  Ind
  (consT (consT (Other nat) nilT)
    (consT (consT Self (consT Self nilT))
      nilT))
  (indSelf := natTree)
  (consF (f := constructorTy natTree) (x := consT (Other nat) nilT) Leaf
    (consF (f := constructorTy natTree)
      (x := consT Self (consT Self nilT))
      Node nilF))
  natTree_rect.

(** We can't have our cake and eat it, too: *)
(*Definition argumentInd : inductive :=
  Ind
  (consT nilT
    (consT (consT (Other Type) nilT)
      nilT))
  (indSelf := argument)
  (consF (f := constructorTy argument) (x := nilT) Self
    (consF (f := constructorTy argument) (x := consT (Other Type) nilT) Other nilF))
  argument_rect.*)

(** * A generic size function *)

Definition sizeCase (self : Type) (con : constructor)
  (cval : constructorTy self con) (acc : nat)
  : constructorIH (fun _ => nat) con cval.
  induction con; simpl; intros.

  exact (S acc).

  destruct t; intros.

  exact (IHcon (cval x) (acc + H)).

  exact (IHcon (cval x) acc).
Defined.

Definition size (ind : inductive) : indSelf ind -> nat.
  destruct ind; simpl.
  generalize (indRec0 (fun _ => nat)); clear indRec0; intro indRec0.

  induction indConTypes0; simpl in *; intuition.

  generalize (IHindConTypes0
    (tailF indCons0)
    (indRec0 (sizeCase _ _ _ O))
    X); trivial.
Defined.

Eval compute in size boolInd false.
Eval compute in size boolInd true.
Eval compute in size boolInd.

Eval compute in size natInd O.
Eval compute in size natInd (S O).
Eval compute in size natInd.

Eval compute in size natListInd nil.
Eval compute in size natListInd (1 :: nil).
Eval compute in size natListInd (1 :: 2 :: nil).
Eval compute in size natListInd.

Eval compute in size natTreeInd (Leaf 5).
Eval compute in size natTreeInd (Node (Leaf 5) (Leaf 8)).
Eval compute in size natTreeInd (Node (Node (Leaf 5) (Leaf 6)) (Leaf 8)).
Eval compute in size natTreeInd.

Theorem natList_size : forall x ls, size natListInd (x :: ls) = S (size natListInd ls).
  reflexivity.
Qed.

(** * A generic fold function *)

Definition fold (ind : inductive) (A : Type)
  (f : forall (con : constructor) (cval : constructorTy (indSelf ind) con),
    A -> constructorIH (fun _ => A) con cval)
  : A -> indSelf ind -> A.
  destruct ind; simpl.
  intros A f i.
  generalize (indRec0 (fun _ => A)); clear indRec0; intro indRec0.

  induction indConTypes0; simpl in *; intros.

  exact (indRec0 X).

  generalize (IHindConTypes0
    (tailF indCons0)
    (indRec0 (f _ _ i))).
  intro IH.
  exact (IH X).
Defined.

Definition size' (ind : inductive) : indSelf ind -> nat :=
  fold ind (sizeCase _) O.

Eval compute in size' boolInd.
Eval compute in size' natInd.
Eval compute in size' natListInd.
Eval compute in size' natTreeInd.

Definition depthCase (self : Type) (con : constructor)
  (cval : constructorTy self con) (acc : nat)
  : constructorIH (fun _ => nat) con cval.
  induction con; simpl; intros.

  exact (S acc).

  destruct t; intros.

  exact (IHcon (cval x) (max acc H)).

  exact (IHcon (cval x) acc).
Defined.

Definition depth (ind : inductive) : indSelf ind -> nat :=
  fold ind (depthCase _) O.

Eval compute in depth boolInd.
Eval compute in depth natInd.
Eval compute in depth natListInd.
Eval compute in depth natTreeInd.

Definition inorderCase (self : Type) (con : constructor)
  (cval : constructorTy self con) (acc : listT self)
  : constructorIH (fun _ => listT self) con cval.
  induction con; simpl; intros.

  exact acc.

  destruct t; intros.

  exact (IHcon (cval x) (appT acc (consT x X))).

  exact (IHcon (cval x) acc).
Defined.

Definition inorder (ind : inductive) : indSelf ind -> listT (indSelf ind) :=
  fold ind (inorderCase (self := _)) nilT.

Eval compute in inorder boolInd false.
Eval compute in inorder boolInd true.
Eval compute in inorder boolInd.

Eval compute in inorder natInd O.
Eval compute in inorder natInd (S O).
Eval compute in inorder natInd (S (S O)).
Eval compute in inorder natInd.

Eval compute in inorder natListInd nil.
Eval compute in inorder natListInd (1 :: nil).
Eval compute in inorder natListInd (1 :: 2 :: nil).
Eval compute in inorder natListInd (1 :: 2 :: 3 :: nil).
Eval compute in inorder natListInd.

Eval compute in inorder natTreeInd (Leaf 5).
Eval compute in inorder natTreeInd (Node (Leaf 5) (Leaf 8)).
Eval compute in inorder natTreeInd (Node (Node (Leaf 1) (Leaf 2)) (Node (Leaf 3) (Leaf 4))).
Eval compute in inorder natTreeInd (Node (Node (Node (Leaf 0) (Leaf 1)) (Leaf 2)) (Node (Leaf 3) (Leaf 4))).
Eval compute in inorder natTreeInd.


(****************************************************************************

          IEEE754  :  MSBProp

          Laurent Thery, Sylvie Boldo

  ******************************************************************************)
Require Export MSB.
Section MSBProp.
Variable b : Fbound.
Variable precision : nat.
Variable radix : Z.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO : (0 < radix)%Z :=
  Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
Hypothesis precisionGreaterThanOne : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Theorem boundOnePrecision :
 forall a : float,
 Fbounded b a -> (Rabs a < Float 1%nat (precision + Fexp a))%R.
intros a H.
replace (FtoRradix (Float 1%nat (precision + Fexp a))) with
 (FtoRradix (Fshift radix precision (Float 1%nat (precision + Fexp a))));
 [ idtac | apply (FshiftCorrect radix); auto ].
unfold Fshift, FtoRradix, FtoR in |- *; simpl in |- *.
rewrite <- pGivesBound.
replace (precision + Fexp a - precision)%Z with (Fexp a); [ idtac | ring ].
rewrite Rabs_mult; rewrite (fun x y => Rabs_pos_eq (powerRZ x y));
 auto with real zarith.
apply Rlt_monotony_exp; auto with float real zarith.
rewrite Faux.Rabsolu_Zabs; auto with float real zarith.
Qed.

Theorem boundNormalMult :
 forall x y : float,
 Fnormal radix b x ->
 Fbounded b y ->
 (Rabs y * Float 1%nat (Fexp x) < radix * (Rabs x * Float 1%nat (Fexp y)))%R.
intros x y H H0.
apply
 Rlt_le_trans
  with (Float (Zpos (vNum b)) (Fexp y) * Float 1%nat (Fexp x))%R.
apply Rmult_lt_compat_r.
unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *.
replace (1 * powerRZ radix (Fexp x))%R with (powerRZ radix (Fexp x));
 [ idtac | ring ].
apply powerRZ_lt; auto with real arith.
unfold FtoRradix in |- *; apply MaxFloat; auto.
replace (Float (Zpos (vNum b)) (Fexp y) * Float 1%nat (Fexp x))%R with
 (Zpos (vNum b) * Float 1%nat (Fexp x) * Float 1%nat (Fexp y))%R.
replace (radix * (Rabs x * Float 1%nat (Fexp y)))%R with
 (radix * Rabs x * Float 1%nat (Fexp y))%R; [ idtac | ring ].
apply Rmult_le_compat_r.
unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *.
replace (1 * powerRZ radix (Fexp y))%R with (powerRZ radix (Fexp y));
 [ idtac | ring ].
apply powerRZ_le; auto with real arith.
replace (Zpos (vNum b) * Float 1%nat (Fexp x))%R with
 (FtoRradix (Float (Zpos (vNum b)) (Fexp x))).
rewrite <- (Fabs_correct radix); auto with real zarith.
unfold Fabs, FtoRradix, FtoR in |- *.
rewrite <- Rmult_assoc.
apply Rle_monotone_exp; auto with real arith.
rewrite <- Rmult_IZR; apply Rle_IZR; simpl in |- *.
rewrite <- (Zabs_eq radix); auto with zarith; rewrite <- Zabs_Zmult;
 auto with float.
case H; simpl in |- *; auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *; ring.
unfold FtoRradix, FtoR in |- *; simpl in |- *; ring.
Qed.
End MSBProp.


Require Import
  Coq.Classes.Morphisms MathClasses.interfaces.abstract_algebra.

Class Pow A B := pow : A → B → A.
Infix "^" := pow : mc_scope.
Notation "(^)" := pow (only parsing) : mc_scope.
Notation "( x ^)" := (pow x) (only parsing) : mc_scope.
Notation "(^ n )" := (λ x, x ^ n) (only parsing) : mc_scope.
Instance: Params (@pow) 3.

(* If we make [nat_pow_proper] a subclass, Coq is unable to find it.
However, if we make a global instance in theory.nat_pow, it works? *)
Class NatPowSpec A B (pw : Pow A B) `{Equiv A} `{Equiv B} `{One A} `{Mult A} `{Zero B} `{One B} `{Plus B} := {
  nat_pow_proper : Proper ((=) ==> (=) ==> (=)) (^) ;
  nat_pow_0 : ∀ x, x ^ 0 = 1 ;
  nat_pow_S : ∀ x n, x ^ (1 + n) = x * x ^ n
}.

Class IntPowSpec A B (pow : Pow A B) `{Equiv A} `{Equiv B} `{Zero A} `{One A} `{Mult A} `{Zero B} `{One B} `{Plus B} := {
  int_pow_proper : Proper ((=) ==> (=) ==> (=)) (^) ;
  int_pow_0 : ∀ x, x ^ 0 = 1 ;
  int_pow_base_0 : ∀ (n : B), n ≠ 0 → 0 ^ n = 0 ;
  int_pow_S : ∀ x n, x ≠ 0 → x ^ (1 + n) = x * x ^ n
}.

Class ShiftL A B := shiftl: A → B → A.
Infix "≪" := shiftl (at level 33, left associativity) : mc_scope.
Notation "(≪)" := shiftl (only parsing) : mc_scope.
Notation "( x ≪)" := (shiftl x) (only parsing) : mc_scope.
Notation "(≪ n )" := (λ x, x ≪ n) (only parsing) : mc_scope.
Instance: Params (@shiftl) 3.

Class ShiftLSpec A B (sl : ShiftL A B) `{Equiv A} `{Equiv B} `{One A} `{Plus A} `{Mult A} `{Zero B} `{One B} `{Plus B} := {
  shiftl_proper : Proper ((=) ==> (=) ==> (=)) (≪) ;
  shiftl_0 :> RightIdentity (≪) 0 ;
  shiftl_S : ∀ x n, x ≪ (1 + n) = 2 * x ≪ n
}.

Lemma shiftl_spec_from_nat_pow `{SemiRing A} `{SemiRing B} `{!NatPowSpec A B pw} (sl : ShiftL A B) :
  (∀ x n, x ≪ n = x * 2 ^ n) → ShiftLSpec A B sl.
Proof.
  pose proof nat_pow_proper.
  intros spec. split.
    intros ? ? E1 ? ? E2.
    rewrite 2!spec.
    now rewrite E1, E2.
   intro x. rewrite spec, nat_pow_0. now apply right_identity.
  intros x n. rewrite 2!spec. rewrite nat_pow_S.
  now rewrite ?associativity, (commutativity x 2).
Qed.

Lemma shiftl_spec_from_int_pow `{SemiRing A} `{!PropHolds ((2:A) ≠ 0)} `{SemiRing B} `{!IntPowSpec A B ip} (sl : ShiftL A B) :
  (∀ x n, x ≪ n = x * 2 ^ n) → ShiftLSpec A B sl.
Proof.
  pose proof int_pow_proper.
  intros spec. split.
    intros ? ? E1 ? ? E2.
    rewrite 2!spec. now rewrite E1, E2.
   intro x. rewrite spec, int_pow_0. now apply right_identity.
  intros x n. rewrite 2!spec. rewrite int_pow_S by solve_propholds.
  now rewrite ?associativity, (commutativity x 2).
Qed.

Class ShiftR A B := shiftr: A → B → A.
Infix "≫" := shiftr (at level 33, left associativity) : mc_scope.
Notation "(≫)" := shiftr (only parsing) : mc_scope.
Instance: Params (@shiftr) 3.

Class ShiftRSpec A B (sl : ShiftR A B) `{Equiv A} `{Equiv B} `{One A} `{Plus A} `{Mult A} `{Zero B} `{One B} `{Plus B} := {
  shiftr_proper : Proper ((=) ==> (=) ==> (=)) (≫) ;
  shiftr_0 :> RightIdentity (≫) 0 ;
  shiftr_S : ∀ x n, x ≫ n = 2 * x ≫ (1 + n) ∨ x ≫ n = 2 * x ≫ (1 + n) + 1
}.

Class DivEuclid A := div_euclid : A → A → A.
Class ModEuclid A := mod_euclid : A → A → A.
Infix "`div`" := div_euclid (at level 35) : mc_scope.
Notation "(`div`)" := div_euclid (only parsing) : mc_scope.
Notation "( x `div`)" := (div_euclid x) (only parsing) : mc_scope.
Notation "(`div` y )" := (λ x, x `div` y) (only parsing) : mc_scope.
Infix "`mod`" := mod_euclid (at level 40) : mc_scope.
Notation "(`mod` )" := mod_euclid (only parsing) : mc_scope.
Notation "( x `mod`)" := (mod_euclid x) (only parsing) : mc_scope.
Notation "(`mod` y )" := (λ x, x `mod` y) (only parsing) : mc_scope.
Instance: Params (@div_euclid) 2.
Instance: Params (@mod_euclid) 2.

Class EuclidSpec A (d : DivEuclid A) (m : ModEuclid A) `{Equiv A} `{Le A} `{Lt A} `{Zero A} `{Plus A} `{Mult A} := {
  div_proper : Proper ((=) ==> (=) ==> (=)) (`div`) ;
  mod_proper : Proper ((=) ==> (=) ==> (=)) (`mod`) ;
  div_mod : ∀ x y, y ≠ 0 → x = y * x `div` y + x `mod` y ;
  mod_rem : ∀ x y, y ≠ 0 → 0 ≤ x `mod` y < y ∨ y < x `mod` y ≤ 0 ;
  div_0 : ∀ x, x `div` 0 = 0 ;
  mod_0 : ∀ x, x `mod` 0 = 0
}.

Class CutMinus A := cut_minus : A → A → A.
Infix "∸" := cut_minus (at level 50, left associativity) : mc_scope.
Notation "(∸)" := cut_minus (only parsing) : mc_scope.
Notation "( x ∸)" := (cut_minus x) (only parsing) : mc_scope.
Notation "(∸ y )" := (λ x, x ∸ y) (only parsing) : mc_scope.
Instance: Params (@cut_minus) 2.

Class CutMinusSpec A (cm : CutMinus A) `{Equiv A} `{Zero A} `{Plus A} `{Le A} := {
  cut_minus_le : ∀ x y, y ≤ x → x ∸ y + y = x ;
  cut_minus_0 : ∀ x y, x ≤ y → x ∸ y = 0
}.


Require Import Data.Graph.Inductive.Internal.Queue.
Require Import Coq.Lists.List.
Require Import Data.Foldable.
Require Import HsToCoq.DeferredFix.
Require Import Omega.

Section Queue.

Variable a : Type.

(*Tactics*)
Lemma reverse_equiv: forall (l: list a),
  List.reverse l = rev_append l nil.
Proof.
  intros. induction l; unfold List.reverse; simpl; try(reflexivity); try(apply IHl).
Qed.

Ltac unfold_null := unfold null in *; unfold Foldable__list in *; simpl in *;
 unfold Foldable.Foldable__list_null in *; unfold List.null in *.

Ltac rewrite_rev:= rewrite reverse_equiv; rewrite rev_append_rev; simpl.

Definition toList (q: Queue a) : list a :=
  match q with
  | MkQueue x y => y ++ rev x
  end.

Lemma toList_empty: toList mkQueue = nil.
Proof.
  auto.
Qed.

Lemma toList_queuePut : forall q x, toList (queuePut x q) = toList q ++ (x :: nil).
Proof.
  intros.  unfold queuePut. destruct q. simpl. intuition.
Qed.

Lemma toList_queuePutList: forall q l, toList (queuePutList l q) = toList q ++ l.
Proof.
  intros. unfold queuePutList. (* unfold toList. *) unfold Base.flip. unfold foldl'. unfold Foldable__list.
  simpl. unfold Foldable.Foldable__list_foldl'. unfold Base.foldl'. unfold id. generalize dependent q.
  induction l; intros; simpl.
  - rewrite app_nil_r; reflexivity.
  - rewrite IHl. rewrite toList_queuePut. rewrite <- app_assoc. reflexivity.
Qed.

Lemma toList_queueEmpty: forall q, queueEmpty q = true <-> toList q = nil.
Proof.
  intros. unfold queueEmpty. unfold_null. destruct q. unfold toList. destruct l; simpl.
  destruct l0. split; intros; reflexivity. split; intro H; inversion H.
  split; intros H. inversion H. destruct l0. destruct (rev l).
  simpl in H. inversion H. simpl in H. inversion H. simpl in H. inversion H.
Qed.

(** ** Specification for QueueGet **)
(* This is nontrivial because the queueGet function in the library is not only
  nonterminating for empty queues but also recurses on a queue of the same size in the recursive case. To get
  around this restriction and prove that a measure is decreasing, we use a strange measure that actually does
  decrease **)

(*Recursion does from MkQueue x nil -> MkQueue nil x, so this measure does decrease for a nonempty queue*)
Definition queue_size' (q : Queue a) := match q with
  | MkQueue x y => (2 * Datatypes.length x) + (Datatypes.length y)
  end.

(*Prove that this is well-formed*)

Definition queue_order q1 q2 := queue_size' q1 < queue_size' q2.

Lemma queue_order_wf': forall x, forall q, queue_size' q <= x -> Acc queue_order q.
Proof.
  intros. unfold queue_order. generalize dependent q. induction x; intros.
  - apply Acc_intro. intros. assert (queue_size' y < 0) by omega. omega.
  - intros. apply Acc_intro. intros. apply IHx. omega.
Defined.

Lemma queue_order_wf : well_founded queue_order.
Proof.
   red; intro; eapply queue_order_wf'; eauto.
Defined.

(* Total version of betterQueueGet that makes it easier to reason about. It has the same type but we don't
    need to worry about deferredFix once we prove the following lemma*)

Definition flip_queue (q: Queue a) : Queue a :=
  match q with
  | MkQueue (x :: xs) nil => MkQueue nil (rev (x :: xs))
  | MkQueue _ _ => q
  end.

Definition betterQueueGet (q: Queue a) (x : a) : (a * Queue a) :=
   match (flip_queue q) with
  | MkQueue l (x :: xs) => (x, MkQueue l xs)
  | MkQueue _ _ => (x, MkQueue nil nil)
  end.

Instance Queue__Default {a} : HsToCoq.Err.Default (Data.Graph.Inductive.Internal.Queue.Queue a) :=
  { default := Data.Graph.Inductive.Internal.Queue.MkQueue nil nil }.

Lemma queueGet_def: forall q x `{Default a}, queueEmpty q = false -> queueGet q = betterQueueGet q x.
Proof.
  intros. unfold queueGet. unfold deferredFix1. destruct q. destruct l0. destruct l. simpl in H0. inversion H0.
  - remember (MkQueue (a0 :: l) nil) as q. rewrite (deferredFix_eq_on _ (fun x => queueEmpty x = false)
  (fun x y => queue_size' x < queue_size' y)).
    + rewrite Heqq. rewrite_rev.
     rewrite (deferredFix_eq_on _ (fun x => queueEmpty x = false)
  (fun x y => queue_size' x < queue_size' y)).
    * destruct (rev l) eqn : R. simpl. unfold betterQueueGet. simpl. rewrite R. simpl. reflexivity.
      simpl. unfold betterQueueGet. simpl. rewrite R. simpl. rewrite app_nil_r. reflexivity.
    * apply queue_order_wf.
    * unfold recurses_on. intros. destruct x0. destruct l1. destruct l0. simpl in H1. inversion H1.
      apply H2. simpl. rewrite_rev. unfold_null.
      destruct (rev l0);  reflexivity.
      simpl. rewrite_rev. rewrite app_nil_r. rewrite app_length. simpl.  rewrite rev_length. omega.
      reflexivity.
    * simpl. unfold_null. destruct (rev l); reflexivity.
    + apply queue_order_wf.
    + unfold recurses_on. intros. destruct x0. destruct l1. apply H2. unfold queueEmpty in H1.
      unfold queueEmpty. simpl. unfold_null.
      destruct l0. intuition. rewrite_rev.
      destruct (rev l0); reflexivity. simpl. destruct l0. unfold queueEmpty in H1; unfold_null. inversion H1.
      simpl. rewrite_rev. rewrite app_nil_r. rewrite app_length; rewrite rev_length. simpl. omega. reflexivity.
     + apply H0.
  - rewrite (deferredFix_eq_on _ (fun x => queueEmpty x = false)
  (fun x y => queue_size' x < queue_size' y)).
    + unfold betterQueueGet. simpl. destruct l; reflexivity.
    + apply queue_order_wf.
    + unfold recurses_on. intros. destruct x0. destruct l1. destruct l2. unfold queueEmpty in H1.
      unfold_null. inversion H1. reflexivity. destruct l2. apply H2. unfold queueEmpty. unfold_null.
      rewrite_rev. destruct (rev l1); reflexivity. rewrite_rev. rewrite app_nil_r. rewrite app_length.
      rewrite rev_length. simpl. omega. reflexivity.
    + assumption.
Qed.

(*Now, the specification we want*)

Lemma toList_queueGet: forall q x l `{Err.Default a} , toList q = x :: l -> fst (queueGet q) = x
  /\ toList (snd (queueGet q)) = l.
Proof.
  intros. assert (queueEmpty q = false). destruct (queueEmpty q) eqn : E. rewrite toList_queueEmpty in E.
  rewrite E in H0. inversion H0. reflexivity. rewrite (queueGet_def q x). destruct q. destruct l1; simpl.
  - unfold betterQueueGet; simpl. destruct l0 eqn : L. simpl in H0. inversion H0.
    destruct (rev l0) eqn : R; simpl. rewrite L in R. simpl in R. destruct (rev l1); inversion R.
    simpl in H0. rewrite H0. simpl. split; try(rewrite app_nil_r); reflexivity.
  - unfold betterQueueGet; simpl. simpl in H0. inversion H0; subst.
    destruct l0; simpl; split; try(rewrite app_nil_r); try(reflexivity).
  - assumption.
Qed.

End Queue.