(*-------------Description ------------------------------------------------------

This file implements maps on lists. Here we define functions to calculate range
of a function on list l. We also define one-one function predicate and its boolean
counterpart.

Following are the notions defined in this file:

 img f l                  : range set of f on list l
 one_one_on l f             : f is one one on l
 one_one_onb l f            : boolean counterpart of (one_one_on l f)

Lemma one_one_onP (l:list A) (f: A->B)(Hl: NoDup l):
    reflect (one_one_on l f)(one_one_onb l f).

Furthermore, we have results relating the cardinality of domain and range
for various kinds of functions (many one/one one).

---------------------------------------------------------------------------------*)

Require Export SetReflect.
Require Export OrdList.
Require Export OrdSet.

Set Implicit Arguments.

Section List_maps.

  Context { A B: Type }.

  (*------- This definition of map on lists is from standard library --------------*)

  (*  Lemma map_cons (x:A)(l:list A) : map (x::l) = (f x) :: (map l).

      Lemma in_map :
      forall (l:list A) (x:A), In x l -> In (f x) (map l).

      Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.

      Lemma map_length : forall l, length (map l) = length l.   *)

  Lemma map_intro (f: A-> B): forall (l:list A) (x:A), In x l -> In (f x) (map f l).
  Proof. apply in_map. Qed.

  Lemma map_intro1 (f: A-> B)(l: list A) (y:B): (exists x, In x l /\ y = f x) -> In y (map f l).
  Proof. { intros h1. apply in_map_iff. destruct h1 as [x h1].
           destruct h1 as [h1 h2]. exists x. split;auto. } Qed.

  Lemma map_elim (f: A-> B)(l: list A) (y:B): In y (map f l) -> (exists x, In x l /\ y = f x).
  Proof. { intros h1. apply in_map_iff in h1 as h2.
           destruct h2 as [x h2]. destruct h2 as [h2a h2].
           exists x. split;auto. } Qed.
  Lemma map_length_same (f: A-> B)(l: list A): |l| = |map f l|.
  Proof. symmetry;apply map_length. Qed.

  Hint Immediate map_elim map_intro map_intro1 map_length_same: core.

End List_maps.

Hint Immediate map_elim map_intro map_intro1 map_length_same: core.

Section Set_maps.
  Context { A B: ordType }.

  Lemma EM_A: forall x y: A, x=y \/  x<>y.
  Proof.  eauto.  Qed.
  Lemma EM_B: forall x y:B, x=y \/ x<>y.
  Proof. eauto.  Qed.

  Fixpoint img (f:A->B) (l:list A): list B:= match l with
                                        | nil => nil
                                        | a1::l1 => add (f a1) (img f l1)
                                              end.

  Lemma IsOrd_img (f:A->B) (l:list A):  IsOrd (img f l).
  Proof. { induction l. simpl. constructor. simpl. eauto. } Qed.

  Lemma NoDup_img (f:A->B) (l:list A):  NoDup (img f l).
    Proof. cut (IsOrd (img f l)). eauto. apply IsOrd_img. Qed.

  Lemma img_intro1(f: A->B)(l: list A)(a:A)(y: B): In y (img f l)-> In y (img f (a::l)).
    Proof. simpl. eapply set_add_intro1. Qed.
  Lemma img_intro2 (f: A->B)(l: list A)(x:A): In x l -> In (f x) (img f l).
  Proof.  { induction l. simpl.  tauto.
          cut (x=a \/ x <> a).
          intro H;destruct H as [Hl | Hr].
          { intro H. rewrite Hl. simpl. eapply set_add_intro2. auto. }
          { intro H. cut (In x l). intro H1. eapply img_intro1;eauto.
            eapply in_inv2;eauto.  } eauto. } Qed.

  Lemma img_elim (f:A->B) (l: list A)(a0:A)(fa:B): In (fa) (img f (a0::l))->
                                                    fa = f(a0) \/ In fa (img f l).
    Proof. simpl. eapply set_add_elim. Qed.

  Lemma img_elim2 (f:A->B) (l: list A)(a0:A)(fa:B): In (fa) (img f (a0::l))->
                                                   fa <> f(a0) -> In fa (img f l).
  Proof. simpl. eapply set_add_elim2.  Qed.

  Lemma img_elim3 (f:A->B)(l:list A)(a:A): ~ In a l -> In (f a) (img f l) ->
                                           (exists y, In y l /\ f a = f y).
  Proof. { intros H H1. induction l. inversion H1.
         assert (H2: ~ In a l). intro H2; apply H. simpl;tauto.
         cut ( f a = f a0 \/ f a <> f a0 ). intro H3; destruct H3 as [H3a | H3b]. exists a0.
         split; auto. assert (H4: In (f a) (img f l)). eapply img_elim2.
         eapply H1. exact H3b. assert (H5: exists y : A, In y l /\ f a = f y). eauto.
         destruct H5 as [y0 H5]. exists y0. split;  simpl. tauto. tauto.
         eapply EM_B. } Qed.
  Lemma img_elim4 (f: A->B)(l: list A)(b:B): In b (img f l)-> (exists a, In a l /\ b = f a).
  Proof. { induction l.
         { simpl. tauto. }
         { intro H. apply img_elim in H as H1. destruct H1.
           { exists a. split;auto. }
           { apply IHl in H0 as H1.
             destruct H1 as [a' H1]; destruct H1 as [H1 H2].
             exists a'. split;auto. } } } Qed.

  Hint Resolve IsOrd_img NoDup_img : core.
  Hint Resolve img_intro1 img_intro2 img_elim: core.
  Hint Resolve img_elim2 img_elim3 img_elim4: core.

  Lemma map_is_img (f: A-> B)(l: list A): IsOrd (map f l) -> (map f l) = (img f l).
  Proof. { intro h1. apply set_equal. auto. auto.
           split.
           { intros y h2. assert (h3: exists x, In x l /\ y = f x). auto.
             destruct h3 as [x h3]; destruct h3 as [h3a h3]. subst y; auto. }
           { intros y h2. assert (h3: exists x, In x l /\ y = f x). auto.
             destruct h3 as [x h3]; destruct h3 as [h3a h3]. subst y; auto. } } Qed.

  Hint Immediate map_is_img: core.

  Lemma funP (f: A->B)(x y: A): f x <> f y -> x <> y.
  Proof. intros H H1. apply H;rewrite H1; auto. Qed.

  Definition one_one (f: A->B): Prop:= forall x y, x <> y -> f x <> f y.

  Lemma one_oneP1 (f:A->B): one_one f -> forall x y, f x = f y -> x =y.
  Proof. { unfold one_one;intros H x y H1. elim (EM_A x y). tauto.
           intro H2; absurd (f x = f y); auto. } Qed.

  Hint Immediate one_oneP1: core.

  Definition one_one_on (l: list A) (f: A-> B):Prop:= forall x y, In x l-> In y l ->  x<>y -> f x <> f y.

  Lemma one_one_on_elim (l:list A)(f: A-> B): one_one_on l f ->
                                         (forall x y, In x l-> In y l-> f x = f y -> x = y).
  Proof. { unfold one_one_on. intros H x y H1 H2. elim (EM_A x y). tauto.
           intros H3 H4. absurd (f x = f y); auto. } Qed.
  Lemma one_one_on_intro(l:list A)(f: A-> B): (forall x y, In x l-> In y l-> f x = f y -> x = y) ->
                                         (one_one_on l f).
  Proof. { intros H.  unfold one_one_on.
         intros x y H1 H2 H3 H4. apply H3. auto. } Qed.

  Lemma one_one_on_nil (f:A->B): one_one_on nil f.
  Proof. unfold one_one_on. intros x y H H0 H1 H2. inversion H. Qed.

  Lemma one_one_on_intro1(l:list A) (f: A->B)(a:A):
             (~ In (f a) (img f l)) -> (one_one_on l f) -> one_one_on (a::l) f.
  Proof. { unfold one_one_on. intros H H1.
         intros x y H2 H3. destruct H2; destruct H3.
         rewrite <- H0; rewrite <- H2.  tauto.
         rewrite <- H0. intros H3 H4. assert (H5: In (f a) (img f l)). rewrite H4.
         apply img_intro2;auto. absurd (In (f a) (img f l)); assumption.
         rewrite <- H2. intros H3 H4. absurd (In (f a) (img f l)). assumption.
         rewrite <- H4. apply img_intro2;auto. apply H1; auto. } Qed.

  Lemma one_one_on_elim1 (l:list A) (f: A->B)(a: A): one_one_on (a::l) f -> one_one_on l f.
  Proof. { unfold one_one_on.  intro H. intros x y H1 H2. eapply H; auto. } Qed.

  Lemma one_one_on_elim2 (l:list A) (f: A->B)(a: A)(Hl: NoDup (a::l)):
    one_one_on (a::l) f -> ~ In (f a)(img f l).
  Proof. { unfold one_one_on.  intros H H1.
         assert (H2: (exists y, In y l /\ f a = f y)).
         { eapply img_elim3. intro H2; inversion Hl;contradiction. auto. }
         destruct H2 as [b H2]; destruct H2 as [H2 H3].
         eapply H with (x:=a)(y:=b); auto. intro H4. rewrite <- H4 in H2.
         inversion Hl;contradiction. } Qed.

  Hint Immediate one_one_on_nil one_one_on_elim one_one_on_elim1 one_one_on_elim2 : core.
  Hint Immediate one_one_on_intro one_one_on_intro1: core.

  Lemma NoDup_map (f:A->B) (l:list A): NoDup l-> one_one_on l f-> NoDup (map f l).
  Proof. { induction l as [| a l'].
           { simpl. auto. }
           { intros h1 h2. simpl.
             apply nodup_intro.
             { intro h3.
               assert (h3a: exists b, In b l' /\ (f a) = (f b)).
               { auto. } destruct h3a as [b h3a]. destruct h3a as [h3a h3b].
               unfold one_one_on in h2.
               absurd (f a = f b). apply h2. auto. auto. intros h4. subst b.
               absurd (In a l'); auto. auto. }
             apply IHl'. eauto. eauto. } } Qed.

  Hint Resolve NoDup_map: core.

  Lemma map_IsOrd (f: A->B)(l:list A):
    IsOrd l -> (forall x y, In x l-> In y l-> x <b y -> f x <b f y)-> IsOrd (map f l).
  Proof. { induction l as [|a l'].
           { intros h1 h2. simpl. constructor. }
           { intros h1 h2. simpl. apply IsOrd_intro.
             apply IHl'. eauto. intros x y hx hy;apply h2;eauto.
             intros fx h3. assert(h4: exists x, In x l' /\ fx = f x). auto.
             destruct h4 as [x h4]. destruct h4 as [h4 h5].
             subst fx. apply h2;eauto. } } Qed.

  Hint Resolve map_IsOrd: core.

  Fixpoint one_one_onb (l: list A) (f: A->B): bool:=
    match l with
    |nil => true
    | a1::l1 => (negb ( memb (f a1) (img f l1))) && (one_one_onb l1 f)
    end.

   Lemma one_one_onP (l:list A) (f: A->B)(Hl: NoDup l):
    reflect (one_one_on l f)(one_one_onb l f).
  Proof. { apply reflect_intro. split.
         { induction l.
           { unfold one_one_onb. reflexivity. }
           { intro H. simpl one_one_onb. apply /andP. split. cut (~ In (f a)(img f l)).
             intro H1. assert (H2:  memb (f a) (img f l) = false ). apply /membP.
             auto. rewrite H2. simpl. reflexivity. eapply one_one_on_elim2.
             apply Hl. auto. apply IHl.
             eauto. eauto. } }
         { induction l.
           { auto.  }
           { simpl. move /andP. intro H; destruct H as [H H1].
             apply one_one_on_intro1.
             intro H2. unfold negb in H.
             replace (memb (f a) (img f l)) with true in H. inversion H.
             symmetry; apply /membP; eauto. apply IHl. eauto. apply H1. } }  } Qed.

  (*--------- Some more properties of imgs-----------------------------------*)

  Lemma one_one_img_elim (l: list A)(f: A->B)(x: A):
    one_one f -> In (f x) (img f l) -> In x l.
  Proof. { intros H H1. assert (H2: exists a, In a l /\ f x = f a). auto.
         destruct H2 as [a H2]. destruct H2 as [H2 H3].
         cut (x = a). intros; subst x; auto. eauto. } Qed.

  Lemma img_subset (l s: list A)(f: A->B): l [<=] s -> (img f l) [<=] (img f s).
  Proof. { intros H fx H1. assert (H2: exists x, In x l /\ fx = f x). auto.
         destruct H2 as [x H2]. destruct H2 as [H2 H3]. subst fx; auto. } Qed.

  Lemma img_size_less (l: list A)(f: A->B): |img f l| <= |l|.
  Proof.  { induction l.
          { simpl;auto. }
          { simpl. assert (H: (| add (f a) (img f l) |) <= S (| img f l |)).
            auto. omega. } } Qed.

  Lemma img_size_same (l: list A)(f: A->B): NoDup l -> one_one_on l f-> |l|=| img f l|.
  Proof.  { induction l.
          { simpl. auto. }
          { intros H H1.
            assert (Hl: NoDup l). eauto.
            assert (H1a: one_one_on l f). eauto.
            assert (H2: (| l |) = (| img f l |)). auto.
            simpl. assert (H3: ~ In (f a) (img f l)). auto.
            rewrite H2; symmetry;auto. }  } Qed.

  Hint Resolve img_subset img_size_less img_size_same: core.

  Lemma img_strict_less (l: list A)(f: A->B):
    NoDup l -> (|img f l| < |l|) -> ~ one_one_on l f.
  Proof. intros H H1 H2. assert(H3: |l|=| img f l|). auto. omega. Qed.

  Hint Immediate one_one_img_elim  img_strict_less : core.

  Lemma one_one_on_intro2 (l: list A)(f: A->B):
    NoDup l -> (|img f l| = |l|)->  one_one_on l f.
  Proof.  { induction l.
          { simpl; auto. }
          { intros H H0.
            assert (Ha: NoDup l). eauto.
            assert (Hb: ~ In a l ). auto.
            assert (H1: |img f l| = |l|).
            { match_up  (| img f l |)  (| l |).
              { auto. }
              { assert ((| img f (a :: l) |) <b (| a :: l |)).
                { move /ltP in H1. apply /ltP. simpl.
                  cut ((| add (f a) (img f l) |) <= S (|img f l|)). omega.
                  auto. } by_conflict. }
              { assert (H2: |img f l| <= |l|). auto.
                move /lebP in H2. auto. } }
            assert (H2: one_one_on l f). auto.
            assert (H3: ~ In (f a) (img f l)).
            { intro H3.
              assert (H4: img f (a :: l) = (img f l)).
              { simpl. eapply add_same. auto. auto. }
              rewrite H4 in H0. rewrite H1 in H0. simpl in H0. omega. } auto. } } Qed.

  Lemma one_one_on_intro3 (l s: list A)(f: A-> B): s [<=] l -> one_one_on l f -> one_one_on s f.
  Proof. intros H0 H1; unfold one_one_on; auto. Qed.

  Hint Immediate one_one_on_intro2 one_one_on_intro3 : core.

  (* ------------ set maps and set add interaction ------------------------ *)

  Lemma img_add (a: A)(l: list A)(f: A-> B): img f (add a l) = add (f a) (img f l).
  Proof. { apply set_equal;auto.
         induction l.
         { simpl. auto. }
         {  simpl.
           assert (H:  img f (add a l) = add (f a) (img f l)).
           apply set_equal; auto.
           destruct IHl as [IHl IHl1].  match_up a  a0.
           { subst a. simpl. auto. }
           { simpl. auto. }
           { simpl. rewrite H. auto. } }  } Qed.

  Lemma img_same (l: list A) (f g: A->B): (forall x, In x l -> f x = g x)-> (img f l = img g l).
  Proof. {  induction l.
         { simpl; auto. }
         { intro h1. simpl. replace (g a) with (f a). replace (img g l) with (img f l).
           auto. apply IHl. intros x h2. apply h1; auto. apply h1; auto. } } Qed.

  Hint Resolve img_add img_same: core.

  Lemma img_inter1 (l s: list A)(f: A-> B): img f (l [i] s) [<=] (img f l) [i] (img f s).
  Proof. { intros y hy.
           assert(h1: exists x, In x (l [i] s) /\ y = f  x); auto.
           destruct h1 as [x h1]. destruct h1 as [h1a h1].
           cut (In y (img f s)). cut (In y (img f l)). auto.
           subst y. cut (In x l); auto. eauto.
           subst y. cut (In x s); auto. eauto. } Qed.

  Lemma img_inter2 (l s: list A)(f: A-> B): one_one_on (l [u] s) f ->
                                             img f (l [i] s) = (img f l) [i] (img f s).
  Proof. { intros h. apply set_equal. all: auto.
           split. apply img_inter1. intros y h1.
           assert (h1a: In y (img f l)). eauto.
           assert (h1b: In y (img f s)). eauto.
           assert (hx1: exists x, In x l /\ y = f x). auto.
           destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h2].
           assert (hx2: exists x, In x s /\ y = f x). auto.
           destruct hx2 as [x2 hx2]. destruct hx2 as [hx2 h3].
           subst y. assert (h4: x1 = x2).
           cut (In x1 (l [u] s)). cut (In x2 (l [u] s)). eauto.
           all: auto.
           assert (h5: In x1 (l [i] s)). rewrite <- h4 in hx2; auto. auto. } Qed.

  Lemma img_union (l s: list A)(f: A-> B): img f (l [u] s) = (img f l) [u] (img f s).
  Proof.  { apply set_equal. all: auto.
            split.
            { intros y h1.
              assert (hx1: exists x, In x (l [u] s) /\ y = f x). auto.
              destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h2].
              assert (h3: In x1 l \/ In x1 s). auto. destruct h3 as [h3 | h3].
              cut (In y (img f l)). auto. subst y. auto.
              cut (In y (img f s)). auto. subst y. auto. }
            { intros y h1.
              assert (h2: In y (img f l) \/ In y (img f s)). auto.
              destruct h2 as [h2a | h2b].
              { assert (hx1: exists x, In x l /\ y = f x). auto.
                destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h3].
                assert (h4: In x1 (l [u] s)). auto. subst y. auto. }
              { assert (hx1: exists x, In x s /\ y = f x). auto.
                destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h3].
                assert (h4: In x1 (l [u] s)). auto. subst y. auto. } } } Qed.

  Lemma img_diff (l s: list A)(f: A-> B): one_one_on (l [u] s) f ->
                                           img f (l [\] s) = (img f l) [\] (img f s).
  Proof.  { intros h. apply set_equal. all: auto.
            split.
            { intros y h1.
              assert (hx1: exists x, In x (l [\] s) /\ y = f x). auto.
              destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h2].
              assert (hx1l: In x1 l). eauto.
              assert (hx1s: ~ In x1 s). eauto.
              cut (~ In y (img f s)). cut ( In y (img f l)). auto.
              subst y. auto. intro h3.
              assert (hx2: exists x, In x s /\ y = f x). auto.
              destruct hx2 as [x2 hx2]. destruct hx2 as [hx2 h4].
              assert (h5: x1 = x2).
              cut(In x1 (l [u] s)). cut(In x2 (l [u] s)). cut (f x1 = f x2).
              eauto. subst y;auto. all: auto.
              absurd (In x2 s). subst x2. all: auto. }
            { intros y h1.
              assert (hyl: In y (img f l)). eauto.
              assert (hys: ~ In y (img f s)). eauto.
              assert (hx: exists x, In x l /\ y = f x). auto.
              destruct hx as [x hx]. destruct hx as [hx h2].
              assert (hxs: ~ In x s).
              { intro h3. absurd (In y (img f s)). auto.
                subst y. auto. }
              cut (In x (l [\] s)). subst y. auto. auto. } } Qed.

  Hint Resolve img_inter1 img_inter2 img_union img_diff: core.

End Set_maps.

Hint Resolve IsOrd_img NoDup_img : core.
Hint Resolve img_intro1 img_intro2 img_elim: core.
Hint Resolve img_elim2 img_elim3 img_elim4 : core.
Hint Immediate one_oneP1: core.

Hint Resolve NoDup_map: core.
Hint Resolve map_IsOrd: core.

Hint Immediate map_is_img: core.
Hint Immediate one_one_on_nil one_one_on_elim one_one_on_elim1 one_one_on_elim2 : core.
Hint Immediate one_one_on_intro one_one_on_intro1: core.
Hint Resolve one_one_onP: core.

Hint Resolve img_subset img_size_less img_size_same: core.
Hint Immediate one_one_img_elim img_strict_less : core.

Hint Immediate one_one_on_intro2 one_one_on_intro3 : core.

Hint Resolve img_add img_same: core.

Hint Resolve img_inter1 img_inter2 img_union img_diff: core.

Section Map_composition.

  Context {A B C: ordType}.

  (*-------------------------  A  --f-->  B  --g-->  C    --------------------------------*)

  Lemma range_of_range (l:list A)(f: A->B)(g: B->C):
    img g (img f l) = img ( fun x => g (f x)) l.
  Proof. { assert (H: Equal  (img g (img f l)) (img ( fun x => g (f x)) l) ).
         { unfold Equal.
           split.
           { unfold Subset. intros c Hc.
             assert (Hb: exists b, In b (img f l) /\ c = g b). auto.
             destruct Hb as [b Hb]. destruct Hb as [Hb Hb1].
             assert (Ha: exists a, In a l /\ b = f a). auto.
             destruct Ha as [a Ha]. destruct Ha as [Ha Ha1].
             rewrite Hb1. set (gf := (fun x : A => g (f x))).
             rewrite Ha1.
             assert (H: (g (f a)) = (gf a)). unfold gf. auto.
             rewrite H. eapply img_intro2. auto. }
           { unfold Subset. intros c Hc.
             assert (Ha: exists a, In a l /\ c = g (f a)). auto.
             destruct Ha as [a Ha]. destruct Ha as [Ha1 Ha2].
             subst c. auto. } }  auto. } Qed.

  Hint Resolve range_of_range: core.
End Map_composition.

Hint Resolve range_of_range: core.

Section Maps_on_A.
  Context {A: ordType}.

    (*----------Identity map and its properties ---------------------------------*)

  Definition id:= fun (x:A)=> x.

  Lemma id_is_identity1 (l:list A) : l [=] img id l.
  Proof.  { induction l.
          { simpl. auto. }
          { simpl.  split.
           { intros x h. destruct h as [h | h].
             subst a. unfold id. auto.
             cut (In x (img id l)). auto.  apply IHl. auto. }
           { unfold id. fold id. intros x h.
             cut (x=a \/ In x (img id l)).
             intro h1. destruct h1 as [h1a | h1b].
             subst x. all: auto. cut (In x l). auto. apply IHl. auto. } } }  Qed.

  Lemma id_is_identity (l:list A)(hl: IsOrd l): l = img id l.
  Proof. { induction l.
         { simpl. auto. }
         { apply set_equal. auto. auto.
           simpl. replace (img id l) with l.
           split.
           { intros x h. destruct h as [h | h].
             subst a. unfold id. auto. unfold id. auto. }
           { unfold id. intros x h. cut (x=a \/ In x l).
             intro h1. destruct h1 as [h1a | h1b].
             subst x. all: auto. } eauto. } }  Qed.

  Hint Immediate id_is_identity id_is_identity1: core.

  End Maps_on_A.

Hint Immediate id_is_identity id_is_identity1: core.

Section One_one_onto.

  Context {A B: ordType}.
  Variable (da:A).

   (*-------------invertible functions --------------------------------------- *)

  Lemma one_one_onto (l: list A)(s: list B)(f: A-> B):
    IsOrd l -> IsOrd s -> one_one_on l f -> s = img f l ->
    exists g, (one_one_on s g /\ l = img g s /\ forall x, In x l -> g (f x) = x).
  Proof. { revert s. induction l.
         { (*-------base step: when l is nil------*)
           simpl. intros s h1 h2 h3 h4.
           exists (fun x:B => da).
           subst s. split. auto. split. auto. auto. }
         { (*------ induction step: when l is a::l ---------*)
           intros s h1 h2 h3 h4. simpl in h4. subst s. simpl.
           assert (h5: exists g : B -> A, one_one_on (img f l) g /\
                                    l = img g (img f l) /\ (forall x : A, In x l -> g (f x) = x)).
           { apply IHl. all: auto. eauto. eauto. }
           destruct h5 as [g0 h5].
           set (g:= fun y:B => match (y == f(a)) with
                            | true => a
                            | false => g0 y
                            end).
           assert (hga: g (f a) = a).
           { unfold g. replace (f a == f a) with true. auto. auto. }
           assert (hg_g0: forall x:A, In x l -> g (f x) = g0 (f x)).
           { intros x h6. unfold g.
             assert (h6a: x <> a).
             { intro  h7. subst x; absurd (In a l); auto. }
             assert (h6b: f x <> f a). auto.
             { replace (f x == f a) with false. auto. auto. } }
           assert (hgg0: img g0 (img f l) = img g (img f l)).
           { eapply img_same. intros y h6.
             assert (h7: exists x, In x l /\ y = f x ). auto.
             destruct h7 as [x h7]. destruct h7 as [h7a h7].
             symmetry. subst y. auto. }

           exists g. split.
           { (*-------one_one_on (add (f a) (img f l)) g -------*)
             apply one_one_on_intro. intros x y hx hy h6.
             unfold g in h6.
             destruct (x == f a) eqn: hxa; destruct (y == f a) eqn: hya.
             { move /eqP in hxa;move /eqP in hya. subst x. auto. }
             { absurd (a = g0 y).
               cut (In (g0 y) l). cut (NoDup (a::l)). eauto.
               auto.
               assert (h5a: l = img g0 (img f l)). apply h5.
               rewrite h5a. cut (In y (img f l)). auto. move /eqP in hya. eauto.
               auto. }
             { absurd (a = g0 x).
               cut (In (g0 x) l). cut (NoDup (a::l)). eauto.
               auto.
               assert (h5a: l = img g0 (img f l)). apply h5.
               rewrite h5a. cut (In x (img f l)). auto. move /eqP in hxa. eauto.
               auto. }
             { assert (h5a: one_one_on (img f l) g0). apply h5.
               move /eqP in hxa. move /eqP in hya.
               cut (In x (img f l)). cut (In y (img f l)). eauto.
               all: eauto. } }
           split.
           { (*------- a :: l = img g (add (f a) (img f l)) -------*)
             destruct h5 as [h5a h5]. destruct h5 as [h5b h5].
             assert (h6: img g (add (f a) (img f l)) = add (g (f a)) (img g (img f l))).
             auto. rewrite h6. rewrite <- hgg0. rewrite <- h5b. rewrite hga.
             auto. }
           { (*--------  forall x : A, a = x \/ In x l -> g (f x) = x --------*)
             intros x h6. destruct h6 as [h6 | h6]. subst x. auto.
             replace (g (f x)) with (g0 (f x)). apply h5. auto.
             symmetry;auto. } } } Qed.

End One_one_onto.

Hint Resolve one_one_onto: core.

Section PHP.

  Context {A B: ordType}.

  Variable R: A -> B-> Prop.

  Lemma php_eq (l: list A)(s: list B):
    IsOrd l -> IsOrd s -> (|l| = |s|) -> (forall x, In x l -> (exists y, In y s /\ R x y))->
                                (forall x y z, In x l -> In y l -> In z s -> R x z -> R y z -> x = y)->
                                (forall y, In y s -> (exists x, In x l /\ R x y )).
  Proof. { revert s. induction l as [|a l'].
           { intros s h1 h2 h3 h4 h5.
             assert (h6: s = nil).
             { symmetry in h3. destruct s.
               simpl. auto. simpl in h3. inversion h3. }
             subst s. simpl. tauto. }
           { intros s h1 h2 h3 h4 h5.
             assert (h4a: exists b : B, In b s /\ R a b).
             { apply h4. auto. }
             destruct h4a as [b h4a].
             set (s':= rmv b s).
             assert (hs: s = add b s').
             { subst s'. cut (In b s). auto. apply h4a. }
             assert (h6: |l'| = |s'|).
             { rewrite hs in h3.
               replace (| add b s'|) with (S (|s'|)) in h3. simpl in h3.
               omega. symmetry. cut (~ In b s'). auto. subst s'.
               apply set_rmv_elim3. auto. }

             assert (h7: forall y : B, In y s' -> exists x : A, In x l' /\ R x y ).
             { apply IHl'. eauto. subst s'. eauto. auto.
               { (*--  forall x : A, In x l' -> exists y : B, In y s' /\ R x y --*)
                 intros x h7.
                 assert (h4b: exists y : B, In y s /\ R x y).
                 { apply h4. auto. }
                 destruct h4b as [b' h4b]. destruct h4b as [h4b h4c].
                 exists b'. split. Focus 2.  auto.
                 rewrite hs in h4b.
                 assert (h8: b' = b \/ In b' s'). auto.
                 destruct h8 as [h8 |h8].
                 { absurd ( x = a). intro h9. subst x.
                   absurd (In a l'); auto. subst b'.
                   eapply h5. all: auto. apply h4a. auto. apply h4a. }
                 auto. }
               intros x y z hx hy hz h7. eapply h5. all: auto.
               rewrite hs. auto. }

             intros y h8.
             assert (h8a: y = b \/ In y s').
             { rewrite hs in h8. auto. }
             destruct h8a as [h8a | h8b].
             { exists a. split. auto. subst y. apply h4a. }
             { specialize (h7 y h8b) as h7a. destruct h7a as [x h7a].
               exists x. split. cut (In x l'). auto. all: apply h7a. } } } Qed.

  End PHP.


(* ** Abstract Reduction Systems *)
(* from Semantics Lecture at Programming Systems Lab, https://www.ps.uni-saarland.de/courses/sem-ws13/ *)

Require Export Undecidability.Shared.Libs.PSL.Base Lia.

Module ARSNotations.
  Notation "p '<=1' q" := (forall x, p x -> q x) (at level 70).
  Notation "p '=1' q" := (forall x, p x <-> q x) (at level 70).
  Notation "R '<=2' S" := (forall x y, R x y -> S x y) (at level 70).
  Notation "R '=2' S"  := (forall x y, R x y <-> S x y) (at level 70).
End ARSNotations.

Import ARSNotations.

(* Relational composition *)

Definition rcomp X Y Z (R : X -> Y -> Prop) (S : Y -> Z -> Prop)
: X -> Z -> Prop :=
  fun x z => exists y, R x y /\ S y z.

(* Power predicates *)

Require Import Arith.
Definition pow X R n : X -> X -> Prop := it (rcomp R) n eq.

Definition functional {X Y} (R: X -> Y -> Prop) := forall x y1 y2, R x y1 -> R x y2 -> y1 = y2.
Definition terminal {X Y} (R: X -> Y -> Prop) x:= forall y, ~ R x y.

Section FixX.
  Variable X : Type.
  Implicit Types R S : X -> X -> Prop.
  Implicit Types x y z : X.

  Definition reflexive R := forall x, R x x.
  Definition symmetric R := forall x y, R x y -> R y x.
  Definition transitive R := forall x y z, R x y -> R y z -> R x z.

  (* Reflexive transitive closure *)

  Inductive star R : X -> X -> Prop :=
  | starR x : star R x x
  | starC x y z : R x y -> star R y z -> star R x z.

  Definition evaluates R x y := star R x y /\ terminal R y.

  (* Making first argument a non-uniform parameter doesn't simplify the induction principle. *)

  Lemma star_simpl_ind R (p : X -> Prop) y :
    p y ->
    (forall x x', R x x' -> star R x' y -> p x' -> p x) ->
    forall x, star R x y -> p x.
  Proof.
    intros A B. induction 1; eauto.
  Qed.

  Lemma star_trans R:
    transitive (star R).
  Proof.
    induction 1; eauto using star.
  Qed.

  Lemma R_star R: R <=2 star R.
  Proof.
    eauto using star.
  Qed.

  Instance star_PO R: PreOrder (star R).
  Proof.
    constructor;repeat intro;try eapply star_trans;  now eauto using star.
  Qed.

  (* Power characterization *)

  Lemma star_pow R x y :
    star R x y <-> exists n, pow R n x y.
  Proof.
    split; intros A.
    - induction A as [|x x' y B _ [n IH]].
      + exists 0. reflexivity.
               + exists (S n), x'. auto.
               - destruct A as [n A].
                 revert x A. induction n; intros x A.
                 + destruct A. constructor.
                 + destruct A as [x' [A B]]. econstructor; eauto.
  Qed.

  Lemma pow_star R x y n:
    pow R n x y -> star R x y.
  Proof.
    intros A. erewrite star_pow. eauto.
  Qed.

  (* Equivalence closure *)

  Inductive ecl R : X -> X -> Prop :=
  | eclR x : ecl R x x
  | eclC x y z : R x y -> ecl R y z -> ecl R x z
  | eclS x y z : R y x -> ecl R y z -> ecl R x z.

  Lemma ecl_trans R :
    transitive (ecl R).
  Proof.
    induction 1; eauto using ecl.
  Qed.

  Lemma ecl_sym R :
    symmetric (ecl R).
  Proof.
    induction 1; eauto using ecl, (@ecl_trans R).
  Qed.

  Lemma star_ecl R :
    star R <=2 ecl R.
  Proof.
    induction 1; eauto using ecl.
  Qed.

  (* Diamond, confluence, Church-Rosser *)

  Definition joinable R x y :=
    exists z, R x z /\ R y z.

  Definition diamond R :=
    forall x y z, R x y -> R x z -> joinable R y z.

  Definition confluent R := diamond (star R).

  Definition semi_confluent R :=
    forall x y z, R x y -> star R x z -> joinable (star R) y z.

  Definition church_rosser R :=
    ecl R <=2 joinable (star R).

  Goal forall R, diamond R -> semi_confluent R.
  Proof.
    intros R A x y z B C.
    revert x C y B.
    refine (star_simpl_ind _ _).
    - intros y C. exists y. eauto using star.
    - intros x x' C D IH y E.
      destruct (A _ _ _ C E) as [v [F G]].
      destruct (IH _ F) as [u [H I]].
      assert (J:= starC G H).
      exists u. eauto using star.
  Qed.

  Lemma diamond_to_semi_confluent R :
    diamond R -> semi_confluent R.
  Proof.
    intros A x y z B C. revert y B.
    induction C as [|x x' z D _ IH]; intros y B.
    - exists y. eauto using star.
             - destruct (A _ _ _ B D) as [v [E F]].
               destruct (IH _ F) as [u [G H]].
               exists u. eauto using star.
  Qed.

  Lemma semi_confluent_confluent R :
    semi_confluent R <-> confluent R.
  Proof.
    split; intros A x y z B C.
    - revert y B.
      induction C as [|x x' z D _ IH]; intros y B.
      + exists y. eauto using star.
               + destruct (A _ _ _ D B) as [v [E F]].
                 destruct (IH _ E) as [u [G H]].
                 exists u. eauto using (@star_trans R).
               - apply (A x y z); eauto using star.
  Qed.

  Lemma diamond_to_confluent R :
    diamond R -> confluent R.
  Proof.
    intros A. apply semi_confluent_confluent, diamond_to_semi_confluent, A.
  Qed.

  Lemma confluent_CR R :
    church_rosser R <-> confluent R.
  Proof.
    split; intros A.
    - intros x y z B C. apply A.
      eauto using (@ecl_trans R), star_ecl, (@ecl_sym R).
    - intros x y B. apply semi_confluent_confluent in A.
      induction B as [x|x x' y C B IH|x x' y C B IH].
      + exists x. eauto using star.
               + destruct IH as [z [D E]]. exists z. eauto using star.
               + destruct IH as [u [D E]].
                 destruct (A _ _ _ C D) as [z [F G]].
                 exists z. eauto using (@star_trans R).
  Qed.

  (* End Semantics Library *)

  (* Uniform confluence and parametrized confluence *)

  Definition uniform_confluent (R : X -> X -> Prop ) := forall s t1 t2, R s t1 -> R s t2 -> t1 = t2 \/ exists u, R t1 u /\ R t2 u.

  Lemma functional_uc R :
    functional R -> uniform_confluent R.
  Proof.
    intros F ? ? ? H1 H2. left. eapply F. all:eauto.
  Qed.

  Lemma pow_add R n m (s t : X) : pow R (n + m) s t <-> rcomp (pow R n) (pow R m) s t.
  Proof.
    revert m s t; induction n; intros m s t.
    - simpl. split; intros. econstructor. split. unfold pow. simpl. reflexivity. eassumption.
      destruct H as [u [H1 H2]]. unfold pow in H1. simpl in *. subst s. eassumption.
    - simpl in *; split; intros.
      + destruct H as [u [H1 H2]].
        change (it (rcomp R) (n + m) eq) with (pow R (n+m)) in H2.
        rewrite IHn in H2.
        destruct H2 as [u' [A B]]. unfold pow in A.
        econstructor.
        split. econstructor. repeat split; repeat eassumption. eassumption.
      + destruct H as [u [H1 H2]].
        destruct H1 as [u' [A B]].
        econstructor.  split. eassumption. change (it (rcomp R) (n + m) eq) with (pow R (n + m)).
        rewrite IHn. econstructor. split; eassumption.
  Qed.

  Lemma rcomp_eq (R S R' S' : X -> X -> Prop) (s t : X) : (R =2 R') -> (S =2 S') -> (rcomp R S s t <-> rcomp R' S' s t).
  Proof.
    intros A B.
    split; intros H; destruct H as [u [H1 H2]];
    eapply A in H1; eapply B in H2;
    econstructor; split; eassumption.
  Qed.

  Lemma eq_ref : forall (R : X -> X -> Prop), R =2 R.
  Proof.
    split; tauto.
  Qed.

  Lemma rcomp_1 (R : X -> X -> Prop): R =2 pow R 1.
  Proof.
    intros s t; split;unfold pow in *; simpl in *; intros H.
    - econstructor. split; eauto.
    - destruct H as [u [H1 H2]]; subst u; eassumption.
  Qed.

  Lemma parametrized_semi_confluence (R : X -> X -> Prop) (m : nat) (s t1 t2 : X) :
    uniform_confluent R ->
    pow R m s t1 ->
    R s t2 ->
    exists k l u,
      k <= 1 /\ l <= m /\ pow R k t1 u /\ pow R l t2 u /\ m + k = S l.
  Proof.
    intros unifConfR; revert s t1 t2; induction m; intros s t1 t2 s_to_t1 s_to_t2.
    - unfold pow in s_to_t1. simpl in *. subst s.
      exists 1, 0, t2.
      repeat split; try lia.
      econstructor. split; try eassumption; econstructor.
    - destruct s_to_t1 as [v [s_to_v v_to_t1]].
      destruct (unifConfR _ _ _ s_to_v s_to_t2) as [H | [u [v_to_u t2_to_u]]].
      + subst v. eexists 0, m, t1; repeat split; try lia; eassumption.
      + destruct (IHm _ _ _ v_to_t1 v_to_u) as [k [l [u' H]]].
        eexists k, (S l), u'; repeat split; try lia; try tauto.
        econstructor. split. eassumption. tauto.
  Qed.

  Lemma rcomp_comm R m (s t : X) : rcomp R (it (rcomp R) m eq) s t <-> rcomp (it (rcomp R) m eq) R s t.
  Proof.
    split; intros H;
    [rewrite (rcomp_eq s t (rcomp_1 R) (eq_ref _)) in H;
      rewrite (rcomp_eq s t (eq_ref _) (rcomp_1 R)) |
     rewrite (rcomp_eq s t (eq_ref _) (rcomp_1 R)) in H;
       rewrite (rcomp_eq s t (rcomp_1 R) (eq_ref _))];
    change ((it (rcomp R) m eq)) with (pow R m) in *;
    try rewrite <- pow_add in *;
    rewrite plus_comm; eassumption.
  Qed.

  Lemma parametrized_confluence (R : X -> X -> Prop) (m n : nat) (s t1 t2 : X) :
    uniform_confluent R ->
    pow R m s t1 ->
    pow R n s t2 ->
    exists k l u,
      k <= n /\ l <= m /\ pow R k t1 u /\ pow R l t2 u /\ m + k = n + l.
  Proof.
    revert n s t1 t2; induction m; intros n s t1 t2 unifConR s_to_t1 s_to_t2.
    - unfold pow in s_to_t1. simpl in s_to_t1. subst s.
      exists n, 0, t2. repeat split; try now lia. eassumption.
    - unfold pow in s_to_t1. simpl in *.
      destruct s_to_t1 as [v [s_to_v v_to_t1]].
      destruct (parametrized_semi_confluence unifConR s_to_t2 s_to_v) as
          [k [l [u [k_lt_1 [l_lt_n [t2_to_u [v_to_u H]]]]]]].
      destruct (IHm _ _ _ _ unifConR v_to_t1 v_to_u) as
          [l'[k'[u'[l'_lt_l [k'_lt_m [t1_to_u' [u_to_u' H2]]]]]]].
      exists l', (k + k'), u'.
      repeat split; try lia. eassumption.
      rewrite pow_add.
      econstructor; split; eassumption.
  Qed.

  Lemma uniform_confluent_noloop R x y:
    uniform_confluent R ->
    star R x y -> (forall y', ~ R y y') ->
    ~exists z k, star R x z /\ pow R (S k) z z.
  Proof.
    intros UC (k0&R0)%star_pow Term (z&k1&R1&RL).
    induction R1 in k0,RL,R0|-*.
    -edestruct parametrized_confluence with (m:=k0) (n:=S k1 + k0) as (i0&i1&?&?&?&?&?&?).
     1,2:eassumption.
     now eapply pow_add;eexists;split;eassumption.
     destruct i0. destruct i1.
     +now lia.
     +destruct H2 as (?&?&_). edestruct Term. eauto.
     +destruct H1 as (?&?&_). edestruct Term. eauto.
    -edestruct parametrized_semi_confluence with (R:=R) (2:= R0) as (i0&?&?&?&?&?&?&?). 1,2:eassumption.
     destruct i0. 2:{ destruct H2 as (?&?&_). edestruct Term. eauto. }
     cbn in H2;inv H2.
     eapply IHR1. all:eauto.
  Qed.

 Lemma uc_terminal R x y z n:
    uniform_confluent R ->
    R x y ->
    pow R n x z ->
    terminal R z ->
    exists n' , n = S n' /\ pow R n' y z.
  Proof.
    intros ? ? ? ter. edestruct parametrized_semi_confluence as (k&?&?&?&?&R'&?&?). 1-3:now eauto.
    destruct k as [|].
    -inv R'. rewrite <- plus_n_O in *. eauto.
    -edestruct R' as (?&?&?). edestruct ter. eauto.
  Qed.

  (* classical *)
  Definition classical R x := terminal R x \/ exists y, R x y.

  (* Strong normalisation *)

  Inductive SN R : X -> Prop :=
  | SNC x : (forall y, R x y -> SN R y) -> SN R x.

  Fact SN_unfold R x :
    SN R x <-> forall y, R x y -> SN R y.
  Proof.
    split.
    - destruct 1 as [x H]. exact H.
    - intros H. constructor. exact H.
  Qed.

End FixX.

Existing Instance star_PO.

(* A notion of a reduction sequence which keeps track of the largest occuring state *)

Inductive redWithMaxSize {X} (size:X -> nat) (step : X -> X -> Prop): nat -> X -> X -> Prop:=
  redWithMaxSizeR m s: m = size s -> redWithMaxSize size step m s s
| redWithMaxSizeC s s' t m m': step s s' -> redWithMaxSize size step m' s' t -> m = max (size s) m' -> redWithMaxSize size step m s t.

Lemma redWithMaxSize_ge X size step (s t:X) m:
  redWithMaxSize size step m s t -> size s<= m /\ size t <= m.
Proof.
  induction 1;subst;firstorder (repeat eapply Nat.max_case_strong; try lia).
Qed.

Lemma redWithMaxSize_trans X size step (s t u:X) m1 m2 m3:
 redWithMaxSize size step m1 s t -> redWithMaxSize size step m2 t u -> max m1 m2 = m3 -> redWithMaxSize size step m3 s u.
Proof.
  induction 1 in m2,u,m3|-*;intros.
  -specialize (redWithMaxSize_ge H0) as [].
   revert H1;
     repeat eapply Nat.max_case_strong; subst m;intros. all:replace m3 with m2 by lia. all:eauto.
  - specialize (redWithMaxSize_ge H0) as [].
    specialize (redWithMaxSize_ge H2) as [].
    eassert (H1':=Max.le_max_l _ _);rewrite H3 in H1'.
    eassert (H2':=Max.le_max_r _ _);rewrite H3 in H2'.
    econstructor. eassumption.

    eapply IHredWithMaxSize. eassumption. reflexivity.
    subst m;revert H3;repeat eapply Nat.max_case_strong;intros;try lia.
Qed.

Lemma redWithMaxSize_star {X} f (step : X -> X -> Prop) n x y:
  redWithMaxSize f step n x y -> star step x y.
Proof.
  induction 1;eauto using star.
Qed.

Lemma terminal_noRed {X} (R:X->X->Prop) x y :
  terminal R x -> star R x y -> x = y.
Proof.
  intros ? R'. inv R'. easy. edestruct H. eassumption.
Qed.

Lemma unique_normal_forms {X} (R:X->X->Prop) x y:
  confluent R -> ecl R x y -> terminal R x -> terminal R y -> x = y.
Proof.
  intros CR%confluent_CR E T1 T2.
  specialize (CR _ _ E) as (z&R1&R2).
  apply terminal_noRed in R1. apply terminal_noRed in R2. 2-3:eassumption. congruence.
Qed.

Instance ecl_Equivalence {X} (R:X->X->Prop) : Equivalence (ecl R).
Proof.
  split.
  -constructor.
  -apply ecl_sym.
  -apply ecl_trans.
Qed.

Instance star_ecl_subrel {X} (R:X->X->Prop) : subrelation (star R) (ecl R).
Proof.
  intro. eapply star_ecl.
Qed.

Instance pow_ecl_subrel {X} (R:X->X->Prop) n : subrelation (pow R n) (ecl R).
Proof.
  intros ? ? H%pow_star. now rewrite H.
Qed.

Lemma uniform_confluence_parameterized_terminal (X : Type) (R : X -> X -> Prop) (m n : nat) (s t1 t2 : X):
  uniform_confluent R -> terminal R t1 ->
  pow R m s t1 -> pow R n s t2 -> exists n', pow R n' t2 t1 /\ m = n + n'.
Proof.
  intros H1 H2 H3 H4.
  specialize (parametrized_confluence H1 H3 H4) as (n0&n'&?&?&?&R'&?&?).
  destruct n0.
  -inv R'. exists n'. intuition.
  -exfalso. destruct R' as (?&?&?). eapply H2. eauto.
Qed.

Lemma uniform_confluence_parameterized_both_terminal (X : Type) (R : X -> X -> Prop) (n1 n2 : nat) (s t1 t2 : X):
  uniform_confluent R -> terminal R t1 -> terminal R t2 ->
  pow R n1 s t1 -> pow R n2 s t2 -> n1=n2 /\ t1 = t2.
Proof.
  intros H1 H2 H2' H3 H4.
  specialize (parametrized_confluence H1 H3 H4) as (n0&n'&?&?&?&R'&R''&?).
  destruct n0. destruct n'.
  -inv R'. inv H5. split;first [lia | easy].
  -exfalso. destruct R'' as (?&?&?). eapply H2'. eauto.
  -exfalso. destruct R' as (?&?&?). eapply H2. eauto.
Qed.

Lemma uniform_confluent_confluent (X : Type) (R : X -> X -> Prop):
  uniform_confluent R -> confluent R.
Proof.
  intros H x y y' Hy Hy'. apply ARS.star_pow in Hy as (?&Hy). apply ARS.star_pow in Hy' as (?&Hy').
  edestruct parametrized_confluence as (?&?&z&?&?&?&?&?).
  eassumption. exact Hy. exact Hy'. exists z. split;eapply pow_star. all:eauto.
Qed.

Definition computesRel {X Y} (f : X -> option Y) (R:X -> Y -> Prop) :=
  forall x, match f x with
         Some y => R x y
       | None => terminal R x
       end.

Definition evaluatesIn (X : Type) (R : X -> X -> Prop) n (x y : X) := pow R n x y /\ terminal R y.

Lemma evalevaluates_evaluatesIn X (step:X->X->Prop) s t:
  evaluates step s t -> exists k, evaluatesIn step k s t.
Proof.
  intros [(R&?)%star_pow ?]. unfold evaluatesIn. eauto.
Qed.


(* week-02_exercises.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 23 Aug 2020 *)

(* ********** *)

(* Your name: Koo Zhengqun
   Your e-mail address: zhengqun.koo@u.nus.edu
   Your student number: A0164207L
 *)

(* Your name: Bobbie Soedirgo
   Your e-mail address: sram-b@comp.nus.edu.sg
   Your student number: A0181001A
 *)

(* Your name: Kuan Wei Heng
   Your e-mail address: kuanwh@u.nus.edu
   Your student number: A0121712X
 *)

(**
 %\title{Functional Programming in Coq}%
 %\author{Bobbie Soedirgo, Koo Zhengqun, Kuan Wei Heng}%
 %\date{\today}%
 %\maketitle%
 %\tableofcontents%
 %\newpage%
 *)

(** * Introduction

This assignment first introduces polymorphic datatypes, terms of those polymorphic datatypes, and polymorphic functions over those polymorphic datatypes.

Then, this assignment introduces polymorphic lambda types, and terms of those polymorphic lambda types.

Then, this assignment introduces polymorphic propositions, and proofs of those polymorphic propositions.

The sheer number of types and proofs in this assignment is significant, since they help students internalize Coq's and Gallina's syntax.

%\newpage%
 *)

(* begin hide *)
Require Import Arith Bool.
(* end hide *)

(* ********** *)

(** * Exercise 1 *)

(* definitions given *)

(* begin hide *)
Inductive polymorphic_binary_tree (V : Type) : Type :=
| PLeaf : V -> polymorphic_binary_tree V
| PNode : polymorphic_binary_tree V -> polymorphic_binary_tree V -> polymorphic_binary_tree V.

Fixpoint eqb_polymorphic_binary_tree (V : Type) (eqb_V : V -> V -> bool) (t1 t2 : polymorphic_binary_tree V) : bool :=
  match t1 with
  | PLeaf _ v1 =>
    match t2 with
    | PLeaf _ v2 =>
      eqb_V v1 v2
    | PNode _ t11 t12 =>
      false
    end
  | PNode _ t11 t12 =>
    match t2 with
    | PLeaf _ v2 =>
      false
    | PNode _ t21 t22 =>
      eqb_polymorphic_binary_tree V eqb_V t11 t21
      &&
      eqb_polymorphic_binary_tree V eqb_V t21 t22
    end
  end.

Definition eqb_binary_tree_of_nats (t1 t2 : polymorphic_binary_tree nat) : bool :=
  eqb_polymorphic_binary_tree nat beq_nat t1 t2.
(* end hide *)

(** ** a
Exhibit a Gallina expression of type [polymorphic_binary_tree (nat * bool)].

Answer:

 *)

Definition tree_nat_bool : polymorphic_binary_tree (nat * bool) :=
  PLeaf (nat * bool) (0, true).

(* begin hide *)
Check (tree_nat_bool : polymorphic_binary_tree (nat * bool)).
(* end hide *)

(** ** b
Exhibit a Gallina expression of type [polymorphic_binary_tree (polymorphic_binary_tree nat)].

Answer:

 *)

Definition tree_tree_nat : polymorphic_binary_tree (polymorphic_binary_tree nat) :=
  PLeaf _ (PLeaf _ 0).

(* begin hide *)
Check (tree_tree_nat : polymorphic_binary_tree (polymorphic_binary_tree nat)).
(* end hide *)

(* ********** *)

(** * Exercise 2 *)

(** ** a
To implement an equality function on binary trees of pairs of nats and bools, we can specialize the polymorphic function
[eqb_polymorphic_binary_tree]. This requires us to produce a witness function to test the equality of pairs of nats and bools.
Instead of constructing it directly, we will first write a more general form to test the equality of pairs
parameterized over the types of the car and cdr, then specialize it for [nat * bool] with the witnesses [beq_a] and [beq_b].
 *)

Definition beq_pair (A B : Type) (beq_a : A -> A -> bool) (beq_b : B -> B -> bool) (p1 p2 : A * B) : bool :=
  let (n1, b1) := p1 in
  let (n2, b2) := p2 in
  beq_a n1 n2 && beq_b b1 b2.

Definition eqb_binary_tree_of_nats_and_bools (t1 t2 : polymorphic_binary_tree (nat * bool)) : bool :=
  eqb_polymorphic_binary_tree (nat * bool) (beq_pair nat bool beq_nat eqb) t1 t2.

(** ** b
For binary trees of binary trees of natural numbers, no new definition is needed to construct the witness function.
 *)

Definition eqb_binary_tree_of_binary_trees_of_nats (t1 t2 : polymorphic_binary_tree (polymorphic_binary_tree nat)) : bool :=
  eqb_polymorphic_binary_tree (polymorphic_binary_tree nat) eqb_binary_tree_of_nats t1 t2.

(* ********** *)

(** * Exercises about types
As in Week 04 of Intro to CS, the accompanying file contains 14 types in need of a program that has this type. Conjure up these programs (aiming for the simplest ones you can think of).

Hint: all these programs only need to have the shape <<(fun ... => e)>>, where:
<<
e ::= tt | x | fun x => e | e e | (e, e) | match e with p => e
p ::= x | (p, p)
>>

Because types are never directly used to construct the program, for each type, we <<intro>> it but do not bind it to an identifier (we bind it to [_], which means we ignore it).

These exercises about types have a great similarity to the exercises about propositions. In fact, each of these numbered exercises (from [a] to [n]) correspond to the corresponding numbered exercises about propositions (from [a] to [n]). This allows us to apply insights from these exercises to the exercises about propositions, and vice versa. So let us start with the insights from these exercises.

Answer:

 *)

Definition ta : forall A : Type, A -> A * A :=
  fun _ a => (a, a).

Definition tb : forall A B : Type, A -> B -> A * B :=
  fun _ _ a b => (a, b).

Definition tc : forall A B : Type, A -> B -> B * A :=
  fun _ _ a b => (b, a).

Check (tt : unit).

Definition td : forall (A : Type), (unit -> A) -> A :=
  fun _ f => f tt.

Definition te : forall A B : Type, (A -> B) -> A -> B :=
  fun _ _ f a => f a.

Definition tf : forall A B : Type, A -> (A -> B) -> B :=
  fun _ _ a f => f a.

(**
We note that [tg] is [fun _ _ _ f a b => f a b]. From lambda calculus, we know that this is eta-equivalent to [fun _ _ _ f => f]. So, we know that [pg] can be proven by doing 4 <<intro>>s, then doing <<exact>> on the 4th <<intro>>ed term.

*)
Definition tg : forall A B C : Type, (A -> B -> C) -> A -> B -> C :=
  fun _ _ _ f a b => f a b.

(**
Keeping in mind that [->] associates to the right, we note when compared to [tg : (A -> B -> C) -> (A -> B -> C)], that the exercise [th : (A -> B -> C) -> (B -> A -> C)] is significant, because [th] tells us that despite what the type [(B -> A -> C)] says, we do not need to apply [B] first followed by [A]. This is especially evident in the way the terms are constructed: both [tg] and [th] construct the term as [f a b]. We shall see a more fundamental reason in the exercises about propositoins.

*)

Definition th : forall A B C : Type, (A -> B -> C) -> B -> A -> C :=
  fun _ _ _ f b a => f a b.

Definition ti : forall A B C D : Type, (A -> C) -> (B -> D) -> A -> B -> C * D :=
  fun _ _ _ _ f g a b => (f a, g b).

Definition tj : forall A B C : Type, (A -> B) -> (B -> C) -> A -> C :=
  fun _ _ _ f g a => g (f a).

Definition tk : forall A B : Type, A * B -> B * A :=
  fun _ _ ab => match ab with (a, b) => (b, a) end.

Definition tl : forall A B C : Type, (A * B -> C) -> A -> B -> C :=
  fun _ _ _ f a b => f (a, b).

Definition tm : forall A B C : Type, (A -> B -> C) -> A * B -> C :=
  fun _ _ _ f ab => match ab with (a, b) => f a b end.

(* NOTE: Is (A * B) * C equivalent to A * B * C? *)
Definition tn : forall A B C : Type, (A * (B * C)) -> (A * B) * C :=
  fun _ _ _ a_bc => match a_bc with (a, (b, c)) => ((a, b), c) end.

(* ********** *)

(** * Exercises about propositions
The accompanying file contains 14 propositions in need of a proof. Conjure up these proofs (aiming for the simplest ones you can think of).

Hint: all these proofs only need to use the following tactics:

<<
intro, intros
destruct
split
exact
apply
>>

Here, we write insights from these exercises that can be applied to the exercises about types.

Answer:

 *)

Proposition pa :
  forall A : Prop,
    A -> A * A.
Proof.
  intros A H_A.
  split.
  - exact H_A.
  - exact H_A.
Qed.

Proposition pb :
  forall A B : Prop,
    A -> B -> A * B.
Proof.
  intros A B H_A H_B.
  split.
  - exact H_A.
  - exact H_B.
Qed.

Proposition pc :
  forall A B : Prop,
    A -> B -> B * A.
Proof.
  intros A B H_A H_B.
  split.
  - exact H_B.
  - exact H_A.
Qed.

Check tt.

Proposition pd :
  forall (A : Prop),
    (unit -> A) -> A.
Proof.
  intros A H_f.
  exact (H_f tt).
Qed.

Proposition pe :
  forall A B : Prop,
    (A -> B) -> A -> B.
Proof.
  intros A B H_f H_A.
  exact (H_f H_A).
Qed.

Proposition pf :
  forall A B : Prop,
    A -> (A -> B) -> B.
Proof.
  intros A B H_A H_f.
  exact (H_f H_A).
Qed.

(**
In proving [pg], we apply the insight of eta-conversion to get a proof that uses less tactics (the <<intros>> tactic is counted as many <<intro>>s).

We note that it is possible to prove both [pg] and [ph] by using the <<intro>> tactic as many times as possible. Then, we note that the hypotheses of [pg] are exactly the same as the hypotheses of [ph] (up to bounded names). This strongly suggests that the two propositions are equivalent. Indeed, we notice that each use of the <<intro>> tactic, to introduce a term as a hypothesis, eliminates the left side of only one implication. This corresponds to partial application of the type function of some arity, whereby the aforementioned introduced term is fixed, producing a type function with smaller arity.

 *)

Proposition pg :
  forall A B C : Prop,
    (A -> B -> C) -> A -> B -> C.
Proof.
  intros A B C H_f H_A H_B.
  exact (H_f H_A H_B).

  Restart.

  intros A B C H_f.
  exact H_f.
Qed.

Proposition ph :
  forall A B C : Prop,
    (A -> B -> C) -> B -> A -> C.
Proof.
  intros A B C H_f H_B H_A.
  exact (H_f H_A H_B).
Qed.

Proposition pi :
  forall A B C D : Prop,
    (A -> C) -> (B -> D) -> A -> B -> C /\ D.
Proof.
  intros A B C D H_f H_g H_A H_B.
  split.
  - exact (H_f H_A).
  - exact (H_g H_B).
Qed.

Proposition pj :
  forall A B C : Prop,
    (A -> B) -> (B -> C) -> A -> C.
Proof.
  intros A B C H_f H_g H_A.
  exact (H_g (H_f H_A)).
Qed.

Proposition pk :
  forall A B : Prop,
    A /\ B -> B /\ A.
Proof.
  intros A B.
  intros [H_A H_B].
  split.
  - exact H_B.
  - exact H_A.
Qed.

Proposition pl :
  forall A B C : Prop,
    (A /\ B -> C) -> A -> B -> C.
Proof.
  intros A B C.
  intros H_A_and_B_imp_C H_A H_B.
  exact (H_A_and_B_imp_C (conj H_A H_B)).
Qed.

Proposition pm :
  forall A B C : Prop,
    (A -> B -> C) -> A /\ B -> C.
Proof.
  intros A B C.
  intros H_A_imp_B_imp_C [H_A H_B].
  apply H_A_imp_B_imp_C.
  exact H_A.
  exact H_B.
Qed.

Proposition pn :
  forall A B C : Prop,
    (A /\ (B /\ C)) -> (A /\ B) /\ C.
Proof.
  intros A B C.
  intros [H_A [H_B H_C]].
  exact (conj (conj H_A H_B) H_C).
Qed.

(*** week-01_fixpoints.ml *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 20 Aug 2020, with an attuned definition of infinite_self_composition *)
(* was: *)
(* Version of 19 Aug 2020 *)
(* was: *)
(* Version of 18 Aug 2020 *)

(* ********** *)

(** <<
let rec infinite_self_composition s =
  fun v -> s (infinite_self_composition s) v;;
>> *)

(* ********** *)

(** * Exercise 8 of <<week-01_fixpoints.ml>> *)

(** <<
let test_fib candidate =
  (candidate 0 = 0) &&
  (candidate 1 = 1) &&
  (candidate 2 = 1) &&
  (candidate 3 = 2) &&
  (candidate 4 = 3) &&
  (candidate 5 = 5) &&
  (let n = Random.int 20
   in candidate n = (candidate (n - 1)) + (candidate (n - 2)))
  (* etc. *);;
>>

<<
let test_rev candidate =
  (candidate [] = []) &&
  (candidate [0] = [0]) &&
  (candidate [0; 1] = [1; 0]) &&
  (let vs = [0; 1; 2; 3; 4; 5]
   in candidate (candidate vs) = vs)
  (* etc. *);;
>>

<<
let test_concat candidate =
  (candidate [] [] = []) &&
  (candidate [0] [] = [0]) &&
  (candidate [] [0] = [0]) &&
  (candidate [0; 1; 2] [3; 4; 5] = [0; 1; 2; 3; 4; 5])
  (* etc. *);;
>>

<<
(* Fibonacci *)
let foo n =
  assert (n >= 0);
  infinite_self_composition (fun foo n ->
    if n = 0 then 0 else
    if n = 1 then 1 else
    foo (n - 1) + foo (n - 2)
    ) n;;

let () = assert (test_fib foo);;
>>

<<
(* Reverse list *)
let bar vs =
  infinite_self_composition (fun bar vs ->
    match vs with
    | [] -> []
    | v :: vs' -> bar vs' @ [v]
    ) vs;;

let () = assert (test_rev bar);;
>>

<<
(* Reverse list, but using cons ("::") instead of
the list concatenation operator ("@") *)
let baz vs =
  infinite_self_composition (fun baz vs a ->
    match vs with
    | [] -> a
    | v :: vs' -> baz vs' (v :: a)
    ) vs [];;

let () = assert (test_rev baz);;
>>

<<
(* List concatenation *)
let yip vs ws =
  infinite_self_composition (fun yip vs ws ->
    match vs with
    | [] -> ws
    | v :: vs' -> v :: yip vs' ws
    ) vs ws;;

let () = assert (test_concat yip);;
>>

<<
(* Bonus: Reverse list, but with yip *)
let quux vs =
  infinite_self_composition (fun quux vs ->
    match vs with
    | [] -> []
    | v :: vs' -> yip (quux vs') [v]
    ) vs;;

let () = assert (test_rev quux);;
>> *)

(* ********** *)

(* end of week-01_fixpoints.ml *)

(** * Exercise 12
Prove that disjunction distributes over conjunction on the left and right.

 *)

(** ** Distributes on the left: Given incomplete proof
Prove that disjunction distributes over conjunction on the left.

 *)

Proposition disjunction_distributes_over_conjunction_on_the_left :
  forall A B C : Prop,
    A \/ (B /\ C) <-> (A \/ B) /\ (A \/ C).
Proof.
  intros A B C.
  split.

  - intros [H_A | [H_B H_C]].

    + split.

      * left.
        exact H_A.

      * left.
        exact H_A.

    + split.

      * right.
        exact H_B.

      * right.
        exact H_C.

(** ** Distributes on the left: Completed proof
Prove that disjunction distributes over conjunction on the left.

 *)

  - intros [[H_A | H_B] [H_A' | H_C]].
    + left. exact H_A.
    + left. exact H_A.
    + left. exact H_A'.
    + right.
      exact (conj H_B H_C).
Qed.

(** ** Distributes on the right
Prove that disjunction distributes over conjunction on the right.

 *)

Proposition disjunction_distributes_over_conjunction_on_the_right :
  forall A B C : Prop,
    (B /\ C) \/ A <-> (B \/ A) /\ (C \/ A).
Proof.
  intros A B C.
  split.
  - intros [[H_B H_C] | H_A].
    + split.
      * left. exact H_B.
      * left. exact H_C.
    + split.
      * right. exact H_A.
      * right. exact H_A.
  - intros [[H_B | H_A] [H_C | H_A']].
    + left. exact (conj H_B H_C).
    + right. exact H_A'.
    + right. exact H_A.
    + right. exact H_A.
Qed.

(** * Exercise 13
Prove that conjunction distributes over disjunction on the left and on the right.

 *)

Proposition conjunction_distributes_over_disjunction_on_the_left :
  forall A B C : Prop,
    A /\ (B \/ C) <-> (A /\ B) \/ (A /\ C).
Proof.
  intros A B C.
  split.
  - intros [H_A [H_B | H_C]].
    + left. exact (conj H_A H_B).
    + right. exact (conj H_A H_C).
  - intros [[H_A H_B] | [H_A H_C]].
    + split.
      * exact H_A.
      * left. exact H_B.
    + split.
      * exact H_A.
      * right. exact H_C.
Qed.

Proposition conjunction_distributes_over_disjunction_on_the_right :
  forall A B C : Prop,
    (A \/ B) /\ C <-> (A /\ C) \/ (B /\ C).
Proof.
  intros A B C.
  split.
  - intros [[H_A | H_B] H_C].
    + left. exact (conj H_A H_C).
    + right. exact (conj H_B H_C).
  - intros [[H_A H_C] | [H_B H_C']].
    + split.
      * left. exact H_A.
      * exact H_C.
    + split.
      * right. exact H_B.
      * exact H_C'.
Qed.

(* ********** *)

(** * Conclusion
By the Curry-Howard correspondence, proofs are terms, and propositions are types.

Polymorphism is a significant constraint in this assignment. Because of polymorphism, a term cannot know which of the possible types it is building up to, as in %\href{http://ecee.colorado.edu/ecen5533/fall11/reading/free.pdf}{Wadler}%, which says:
"Say that [r] is a function of type $r : \forall X. X^* \rightarrow X^*$. Here [X] is a type variable, and $X^*$ is the type “list of [X]”. [r] must work on lists of [X] for any type [X]. Since [r] is provided with no operations on values of type [X], all it can do is rearrange such lists, independent of the values contained in them."

Concretely, there is only one solution to exercise [tk]. But if one considers integer-specific types, then alternative solutions are allowed, such as this:

 *)

(* begin hide *)
Require Import BinInt.
Include BinIntDef.Z.
(* end hide *)

Definition tk_int (p : Z * Z) : (Z * Z) :=
  match p with (a, b) =>
               let a := Z.sub b a in
               let b := Z.sub b a in
               let a := Z.add a b in
               (a, b)
  end.

(**
We can write unit tests after defining equality on pairs of integers.

 *)

Definition beq_int_pair (p q : Z * Z) : bool :=
  match p with (a, b) =>
               match q with (c, d) =>
                            eqb a c && eqb b d
               end
  end.

Notation "A =zp= B" :=
  (beq_int_pair A B) (at level 70, right associativity).

Definition test_tk (candidate : (Z * Z) -> (Z * Z)) : bool :=
  ((candidate (Z0,succ Z0)) =zp= (succ Z0,Z0)) &&
  ((candidate (succ Z0,Z0)) =zp= (Z0,succ Z0)) &&
  ((candidate (Z0,succ (succ Z0))) =zp= (succ (succ Z0),Z0)) &&
  ((candidate (succ (succ Z0),Z0)) =zp= (Z0,succ (succ Z0))).

(**
Both the polymorphic [tk] and non-polymorphic [tk_int] pass the unit tests.

 *)

Compute test_tk (tk Z Z).
Compute test_tk tk_int.

(**
As we have seen, only a small amount of term-building operators can be used to manipulate terms that belong to a polymorphic type, because polymorphic types contain less information. For example, we cannot construct [tk] with [tk_int], because the polymorphic type may not be of type int. We do not know which type the polymorphic type is.

Correspondingly, only a small amount of Coq tactics can be used to construct a proof that has only polymorphic types in its assumption.

 *)

(* end of week-02_exercises.v *)


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path order bigop prime.
From favssr Require Import prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section InsertionSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

(* Definition *)

Fixpoint insort x xs :=
  if xs is y :: xs' then
    if x <= y then x :: y :: xs' else y :: insort x xs'
    else [:: x].

Fixpoint isort xs :=
  if xs is x :: xs' then insort x (isort xs') else [::].

(* Functional Correctness *)

Lemma perm_insort x xs : perm_eq (insort x xs) (x :: xs).
Proof.
elim: xs=>//= y xs IH; case: (_ <= _)=>//.
rewrite -(perm_cons y) in IH.
apply: perm_trans; first by exact: IH.
by apply/permP=>/=?; rewrite addnCA.
Qed.

Lemma perm_isort xs : perm_eq (isort xs) xs.
Proof.
elim: xs=>//= x xs IH.
apply: perm_trans; first by apply: perm_insort.
by rewrite perm_cons.
Qed.

Lemma sorted_insort a xs : sorted <=%O (insort a xs) = sorted <=%O xs.
Proof.
elim: xs=>//= x xs IH.
case H: (_ <= _)=>/=; first by rewrite H.
rewrite !le_path_sortedE (perm_all _ (perm_insort _ _)) /= IH.
suff: x <= a by move=>->.
by rewrite leNgt lt_neqAle H andbF.
Qed.

Lemma sorted_isort xs : sorted <=%O (isort xs).
Proof. by elim: xs=>//= x xs; rewrite sorted_insort. Qed.

(* Time complexity *)

Fixpoint T_insort x xs : nat :=
  if xs is y :: xs' then
    (if x <= y then 0 else T_insort x xs').+1
    else 1.

Fixpoint T_isort xs : nat :=
  if xs is x :: xs' then (T_isort xs' + T_insort x (isort xs')).+1 else 1.

Lemma T_insort_size x xs : T_insort x xs <= (size xs).+1.
Proof.
elim: xs=>//=y xs IH.
by case: (x <= y).
Qed.

(* This seems to be unused *)
Lemma size_insort x xs : size (insort x xs) = (size xs).+1.
Proof. by move/perm_size: (perm_insort x xs). Qed.

Lemma size_isort xs : size (isort xs) = size xs.
Proof. by move/perm_size: (perm_isort xs). Qed.

Lemma T_isort_size xs : T_isort xs <= (size xs).+1 ^ 2.
Proof.
elim: xs=>// x xs IH.
rewrite -addn1 sqrnD /= -addn1 -!addnA.
apply: leq_add=>//; rewrite exp1n muln1 addnC leq_add2l.
apply: leq_trans; first by exact: T_insort_size.
by rewrite size_isort; apply: leq_pmull.
Qed.

(* Exercise 2.1 *)

Lemma isort_beh (f : seq T -> seq T) xs :
  perm_eq (f xs) xs -> sorted <=%O (f xs) -> f xs = isort xs.
Proof.
Admitted.

(* Exercise 2.2.1 *)

Lemma T_isort_optimal xs : sorted <=%O xs -> T_isort xs = (2 * size xs).+1.
Proof.
Admitted.

End InsertionSort.

Section InsertionSortNat.

(* uphalf_addn from prelude might come in handy here *)
(* Exercise 2.2.2 *)
Lemma T_isort_worst n : T_isort (rev (iota 0 n)) = uphalf ((n.+1)*(n.+2)).
Proof.
Admitted.

End InsertionSortNat.

Section QuickSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

(* Definition *)

Equations? quicksort xs : seq T by wf (size xs) lt :=
quicksort [::]    => [::];
quicksort (x::xs) => quicksort (filter (< x) xs) ++ [:: x] ++
                     quicksort (filter (>= x) xs).
Proof. all: by rewrite size_filter /=; apply/ssrnat.ltP/count_size. Qed.

(* Functional Correctness *)

Lemma perm_quicksort xs : perm_eq (quicksort xs) xs.
Proof.
apply_funelim (quicksort xs)=>//=x {}xs Hl Hg.
rewrite perm_catC cat_cons perm_cons perm_sym -(perm_filterC (>= x)) perm_sym.
apply: perm_cat=>//.
rewrite (eq_in_filter (a2 := < x)) //= =>y _.
by rewrite ltNge.
Qed.

Lemma sorted_quicksort xs : sorted <=%O (quicksort xs).
Proof.
apply_funelim (quicksort xs)=>//= x {}xs Hl Hg.
have Hx : sorted <=%O [:: x] by [].
move: (merge_sorted le_total Hx Hg)=>{Hx}/=.
rewrite allrel_merge; last first.
- by rewrite allrel1l (perm_all _ (perm_quicksort _)) filter_all.
move/(merge_sorted le_total Hl); rewrite allrel_merge //=.
apply/allrelP=>y z.
rewrite (perm_mem (perm_quicksort _) y) inE
  (perm_mem (perm_quicksort _) z) !mem_filter /=.
case/andP=>Hy _; case/orP=>[/eqP ->|/andP [Hz _]];
rewrite le_eqVlt; apply/orP; right=>//.
by apply/lt_le_trans/Hz.
Qed.

(* Exercise 2.3 *)

Equations? quicksort2 xs ys : seq T by wf (size xs) lt :=
quicksort2 xs ys => ys. (* FIXME *)
Proof.
Qed.

Lemma quick2_quick xs ys : quicksort2 xs ys = quicksort xs ++ ys.
Proof.
Admitted.

(* Exercise 2.4 *)

(* TODO rewrite in one pass? *)
Definition partition3 x xs : seq T * seq T * seq T :=
  (filter (< x) xs, filter (pred1 x) xs, filter (> x) xs).

Equations? quicksort3 xs : seq T by wf (size xs) lt :=
quicksort3 [::]    => [::];
quicksort3 (x::xs) with inspect (partition3 x xs) => {
  | (ls, es, gs) eqn: eq => quicksort3 ls ++ x :: es ++ quicksort3 gs
}.
Proof. all: by apply/ssrnat.ltP; rewrite size_filter; apply: count_size. Qed.

(* this is the main part *)
Lemma quick_filter_ge x xs :
  quicksort (filter (>= x) xs) = filter (pred1 x) xs ++ quicksort (filter (> x) xs).
Proof.
Admitted.

Lemma quick3_quick xs : quicksort3 xs = quicksort xs.
Proof.
Admitted.

(* Exercise 2.5.1 *)

(* TODO move to basics? *)
Fixpoint T_mapfilter {A} (ta : A -> nat) (s : seq A) : nat :=
  if s is x :: s' then ta x + T_mapfilter ta s' + 1 else 1.

Lemma T_mapfilter_size {A} (xs : seq A) ta :
  T_mapfilter ta xs = \sum_(x<-xs) (ta x) + size xs + 1.
Proof.
elim: xs=>/=; first by rewrite big_nil.
by move=>x xs ->; rewrite big_cons -(addn1 (size _)) !addnA.
Qed.

Equations? T_quicksort xs : nat by wf (size xs) lt :=
T_quicksort [::]    => 1;
T_quicksort (x::xs) => T_quicksort (filter (< x) xs) +
                       T_quicksort (filter (>= x) xs) +
                       2 * T_mapfilter (fun => 1%N) xs + 1.
Proof. all: by apply/ssrnat.ltP; rewrite size_filter; apply: count_size. Qed.

(* FIXME replace these with concrete numbers *)
Parameters (a b c : nat).

Lemma quicksort_quadratic xs :
  sorted <=%O xs -> T_quicksort xs = a * size xs ^ 2 + b * size xs + c.
Proof.
Admitted.

(* Exercise 2.5.2 *)

Lemma quicksort_worst xs :
  T_quicksort xs <= a * size xs ^ 2 + b * size xs + c.
Proof.
Admitted.

End QuickSort.

Section TopDownMergeSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

(* reusing `merge` from mathcomp.path *)

Equations? msort xs : seq T by wf (size xs) lt :=
msort [::]  => [::];
msort [::x] => [::x];
msort xs    => let n := size xs in
               merge <=%O (msort (take n./2 xs))
                          (msort (drop n./2 xs)).
Proof.
all: apply/ssrnat.ltP.
- by rewrite size_take /= !ltnS !half_le.
by rewrite size_drop /= /leq subSS subnAC subnn.
Qed.

(* Functional Correctness *)

Lemma perm_msort xs : perm_eq (msort xs) xs.
Proof.
funelim (msort xs)=>//=.
rewrite perm_merge -{3}(cat_take_drop (size l)./2 (s0::l)) -cat_cons.
by apply: perm_cat.
Qed.

Lemma sorted_msort xs : sorted <=%O (msort xs).
Proof. by funelim (msort xs)=>//=; apply: merge_sorted. Qed.

(* Running Time Analysis *)

Fixpoint C_merge xs :=
  if xs is x :: xs' then
    let fix C_merge_xs ys :=
      if ys is y :: ys' then
        (if x <= y then C_merge xs' ys else C_merge_xs ys').+1
      else 0 in
    C_merge_xs
  else fun => 0.

Equations? C_msort xs : nat by wf (size xs) lt :=
C_msort [::]  => 0;
C_msort [::x] => 0;
C_msort xs    => let n := (size xs) in
                 let ys := take n./2 xs in
                 let zs := drop n./2 xs in
                 C_msort ys + C_msort zs + C_merge (msort ys) (msort zs).
Proof.
all: apply/ssrnat.ltP.
- by rewrite size_take /= !ltnS !half_le.
by rewrite size_drop /= /leq subSS subnAC subnn.
Qed.

Lemma C_merge_leq xs ys : (C_merge xs ys <= size xs + size ys)%N.
Proof.
elim: xs ys=>//= x xs IH1; elim=>//= y ys IH2.
case: ifP=>_.
- rewrite -addn1 -!(addn1 (size _)) addnA leq_add2r addnAC.
  apply: leq_trans; first by apply: IH1.
  by rewrite addn1 addnS.
by rewrite addnS ltnS; apply: IH2.
Qed.

Lemma C_msort_leq xs k: size xs = 2^k -> (C_msort xs <= k * 2^k)%N.
Proof.
elim: k xs=>/=.
- by move=>xs; rewrite expn0 =>/size1 [x] ->; simp C_msort.
move=>k IH xs H.
have Hs1 : (size xs > 1)%N by rewrite H -{1}(expn0 2); apply: ltn_exp2l.
case: (size2 Hs1)=> x[y][ys] He; rewrite He /= in H *; simp C_msort=>/=.
have Hp : (size ys)./2.+1 = ((size ys).+2)./2 by rewrite -addn2 halfD andbF /= addn1.
have Ht : size (x :: take (size ys)./2 (y :: ys)) = 2^k.
- by rewrite /= size_take /= ltnS half_le Hp H expnS mul2n half_double.
have Hd : size (drop (size ys)./2 (y :: ys)) = 2^k.
- rewrite size_drop /= subSn; last by apply: half_le.
  by rewrite half_subn uphalf_half -addnS Hp H expnS mul2n half_double odd2 H oddX.
apply: leq_trans;
  first by exact: (leq_add (leq_add (IH _ Ht) (IH _ Hd)) (C_merge_leq _ _)).
rewrite !(perm_size (perm_msort _)) Ht Hd.
by rewrite !addnn -!muln2 -mulnA -!expnSr -{3}(addn1 k) mulnDl mul1n.
Qed.

(* Exercise 2.6 *)

Fixpoint halve {A: Type} (xs ys zs : seq A) : seq A * seq A :=
  ([::],[::]). (* FIXME *)

Equations? msort2 xs : seq T by wf (size xs) lt :=
msort2 [::]  => [::];
msort2 [::x] => [::x];
msort2 xs with inspect (halve xs [::] [::]) := {
  | (ys1, ys2) eqn: eq => merge <=%O (msort2 ys1) (msort2 ys2)
}.
Proof.
all: apply/ssrnat.ltP.
(* FIXME *)
- by [].
by [].
Qed.

Lemma perm_msort2 xs : perm_eq (msort2 xs) xs.
Proof.
Admitted.

Lemma sorted_msort2 xs : sorted <=%O (msort2 xs).
Proof.
Admitted.

End TopDownMergeSort.

Section BottomUpMergeSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

Equations merge_adj : seq (seq T) -> seq (seq T) :=
merge_adj [::]          => [::];
merge_adj [::xs]        => [::xs];
merge_adj (xs::ys::zss) => merge <=%O xs ys :: merge_adj zss.

Lemma size_merge_adj xss : size (merge_adj xss) = uphalf (size xss).
Proof. by funelim (merge_adj xss)=>//=; congr S. Qed.

Equations? merge_all (xss : seq (seq T)) : seq T by wf (size xss) lt :=
merge_all [::]   => [::];
merge_all [::xs] => xs;
merge_all xss    => merge_all (merge_adj xss).
Proof. by apply/ssrnat.ltP; rewrite size_merge_adj /= !ltnS; apply: uphalf_le. Qed.

Definition msort_bu xs : seq T :=
  merge_all (map (fun x => [::x]) xs).

(* Functional Correctness *)

Lemma perm_merge_adj xss : perm_eq (flatten (merge_adj xss)) (flatten xss).
Proof.
funelim (merge_adj xss)=>//=.
rewrite catA; apply: perm_cat=>//.
by rewrite perm_merge.
Qed.

Lemma perm_merge_all xss : perm_eq (merge_all xss) (flatten xss).
Proof.
funelim (merge_all xss)=>//=; first by rewrite cats0.
by apply/(perm_trans H)/perm_merge_adj.
Qed.

Lemma perm_msort_bu xs : perm_eq (msort_bu xs) xs.
Proof.
rewrite /msort_bu; apply: (perm_trans (perm_merge_all _)).
by rewrite flatten_map1 map_id.
Qed.

Lemma sorted_merge_adj xss :
  all (sorted <=%O) xss -> all (sorted <=%O) (merge_adj xss).
Proof.
funelim (merge_adj xss)=>//= /and3P [Hs1 Hs2] /H ->; rewrite andbT.
by apply: merge_sorted.
Qed.

Lemma sorted_merge_all xss :
  all (sorted <=%O) xss -> sorted <=%O (merge_all xss).
Proof.
funelim (merge_all xss)=>//=; first by rewrite andbT.
move: H; simp merge_adj=>/= H.
case/and3P=>Hs1 Hs2 Hs; apply/H/andP.
by split; [apply: merge_sorted | apply: sorted_merge_adj].
Qed.

Lemma sorted_msort_bu xs : sorted <=%O (msort_bu xs).
Proof.
rewrite /msort_bu; apply: sorted_merge_all; rewrite all_map.
by elim: xs.
Qed.

(* Running Time Analysis *)

Equations C_merge_adj : seq (seq T) -> nat :=
C_merge_adj [::]          => 0;
C_merge_adj [::xs]        => 0;
C_merge_adj (xs::ys::zss) => C_merge xs ys + C_merge_adj zss.

Equations? C_merge_all (xss : seq (seq T)) : nat by wf (size xss) lt :=
C_merge_all [::]   => 0;
C_merge_all [::xs] => 0;
C_merge_all xss    => C_merge_adj xss + C_merge_all (merge_adj xss).
Proof. by apply/ssrnat.ltP; rewrite size_merge_adj /= !ltnS; apply: uphalf_le. Qed.

Definition C_msort_bu xs : nat :=
  C_merge_all (map (fun x => [::x]) xs).

Lemma merge_adj_sizes xss m :
  ~~ odd (size xss) -> all (fun xs => size xs == m) xss ->
  all (fun xs => size xs == m.*2) (merge_adj xss).
Proof.
funelim (merge_adj xss)=>//=; rewrite negbK=>Ho /and3P [/eqP Hx /eqP Hy Ha]; apply/andP.
split; last by rewrite (H _ Ho Ha).
by rewrite size_merge size_cat Hx Hy addnn.
Qed.

Lemma C_merge_adj_leq xss m :
  all (fun xs => size xs == m) xss -> C_merge_adj xss <= m * size xss.
Proof.
funelim (C_merge_adj xss)=>//= /and3P [/eqP Hx /eqP Hy Ha].
rewrite -add2n mulnDr muln2 -addnn; apply/leq_add/H=>//.
by rewrite -{1}Hx -Hy; apply: C_merge_leq.
Qed.

Lemma C_merge_all_leq xss m k :
  all (fun xs => size xs == m) xss -> size xss = 2 ^ k ->
  C_merge_all xss <= m * k * 2^k.
Proof.
funelim (C_merge_all xss)=>//= /and3P [/eqP Hx /eqP Hy Ha] Hs.
move: H; simp merge_adj C_merge_adj=>/= H. (* slow for some reason *)
have [k0 Hk] : { k0 | k = k0.+1 } by move: Hs; case: k=>//=k0 _; exists k0.
have He : ~~ odd (size l1) by rewrite odd2 Hs oddX Hk.
rewrite Hk expnS mulnS mulnDl in Hs *; apply: leq_add.
- rewrite -Hs -addn2 mulnDr addnC.
  apply: leq_add; first by apply: C_merge_adj_leq.
  by rewrite muln2 -addnn -{1}Hx -Hy; apply: C_merge_leq.
rewrite mulnCA !mulnA mul2n; apply: H.
- apply/andP; split; last by apply: merge_adj_sizes.
  by rewrite size_merge size_cat Hx Hy addnn.
apply/eqP; rewrite size_merge_adj -addn1 -(eqn_pmul2r (m:=2)) // mulnDl muln2.
have -> : (uphalf (size l1)).*2 = size l1
  by rewrite -[in RHS](odd_double_half (size l1)) uphalf_half (negbTE He).
by rewrite addn2 mulnC Hs.
Qed.

Lemma C_msort_bu_leq xs k : size xs = 2^k -> C_msort_bu xs <= k * 2^k.
Proof.
move=>H; rewrite -(mul1n (_ * _)) mulnA; apply: C_merge_all_leq.
- by rewrite all_map; elim: {H}xs.
by rewrite size_map.
Qed.

End BottomUpMergeSort.

Section NaturalMergeSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T) (xss : seq (seq T)).

Fixpoint runs_fix a xs : seq (seq T) :=
  if xs is b::bs
    then if b < a then desc b [:: a] bs else asc b (cons a) bs
    else [::[::a]]
with asc x (xd : seq T -> seq T) ys : seq (seq T) :=
  if ys is y::ys'
    then if x <= y then asc y (xd \o cons x) ys' else xd [::x] :: runs_fix y ys'
    else [:: xd [::x]]
with desc x xs ys : seq (seq T) :=
  if ys is y::ys'
     then if y < x then desc y (x :: xs) ys' else (x :: xs) :: runs_fix y ys'
     else [:: (x :: xs)].

Definition runs xs : seq (seq T) :=
  if xs is x::xs' then runs_fix x xs' else [::].

Definition nmsort xs := merge_all (runs xs).

(* Functional Correctness *)

Definition is_dlist (xd : seq T -> seq T) :=
  forall ps qs, xd (ps ++ qs) = xd ps ++ qs.

Lemma perm_runs_asc_desc x xs ys xd :
     perm_eq (flatten (runs_fix x ys)) (x :: ys)
  /\ perm_eq (flatten (desc x xs ys)) (x::xs ++ ys)
  /\ (is_dlist xd ->
       perm_eq (flatten (asc x xd ys)) (x :: xd [::] ++ ys)).
Proof.
elim: ys x xs xd=>/=.
- move=>x xs xd; do!split=>//.
  by move=>H; move: (H [::] [::x])=>/=; rewrite !cats0=>->; rewrite perm_catC.
move=>b bs IH x xs xd; do!split.
- case: ifP=>_.
  - apply: perm_trans; first by case: (IH b [::x] xd)=>_ [+ _]; apply.
    by move: (perm_catCA [::b] [::x] bs)=>/=->.
  apply: perm_trans; first by case: (IH b [::x] (cons x))=>_ [_] /=; apply.
  by move: (perm_catCA [::b] [::x] bs)=>/=->.
- case: ifP=>_.
  - apply: perm_trans; first by case: (IH b (x::xs) xd)=>_ [+ _]; apply.
    by move: (perm_catCA [::b] (x::xs) bs)=>/=->.
  rewrite /= -!cat_cons perm_cat2l.
  by case: (IH b xs xd)=>+ _; apply.
move=>H; case: ifP=>_.
- apply: perm_trans.
  - case: (IH b xs (xd \o cons x))=>_ [_] /=; apply=>ps qs.
    by rewrite /= -cat_cons; apply: H.
  move: (H [::] [::x])=>/=->; move: (perm_catCA [::b] (xd [::] ++ [::x]) bs)=>/=->.
  by rewrite -cat_cons perm_cat2r perm_catC.
move: (H [::] [::x])=>/=->; rewrite -cat_cons.
apply: perm_cat; first by rewrite perm_catC.
by case: (IH b xs xd)=>+ _; apply.
Qed.

Lemma perm_runs xs : perm_eq (flatten (runs xs)) xs.
Proof.
case: xs=>//=x xs.
by case: (perm_runs_asc_desc x [::] xs id).
Qed.

Lemma perm_nmsort xs : perm_eq (nmsort xs) xs.
Proof.
rewrite /nmsort; apply/perm_trans/perm_runs.
by apply: perm_merge_all.
Qed.

Lemma sorted_runs_asc_desc x xs ys xd :
     all (sorted <=%O) (runs_fix x ys)
  /\ (sorted <=%O xs -> all (>= x) xs -> all (sorted <=%O) (desc x xs ys))
  /\ (is_dlist xd -> sorted <=%O (xd [::]) -> all (<= x) (xd [::]) ->
      all (sorted <=%O) (asc x xd ys)).
Proof.
elim: ys x xs xd=>/=.
- move=>x xs xd; do!split.
  - by move=>Hs Ha; rewrite andbT le_path_sortedE; apply/andP.
  move=>Hd Hs Ha; rewrite andbT; move: (Hd [::] [::x])=>/=->.
  rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
move=>b ys IH x xs xd; do!split.
- case: ifP=>Ho.
  - case: (IH b [::x] id)=>_ [+ _]; apply=>//.
    by rewrite all_seq1 le_eqVlt Ho orbT.
  case: (IH b xs (cons x))=>_ [_]; apply=>//.
  by rewrite all_seq1 /= leNgt; apply/negbT.
- move=>Hs Ha; case: ifP=>Ho /=.
  - case: (IH b (x::xs) id)=>_ [+ _]; apply=>/=.
    - by rewrite le_path_sortedE; apply/andP.
    rewrite le_eqVlt Ho orbT /=; apply/sub_all/Ha=>z.
    by apply/le_trans; rewrite le_eqVlt Ho orbT.
  rewrite le_path_sortedE Ha Hs /=.
  by case: (IH b xs xd)=>+ _; apply.
move=>Hd Hs Ha; case: ifP=>Ho /=.
- case: (IH b xs (xd \o cons x))=>_ [_] /=; apply.
  - by move=>ps qs /=; rewrite -cat_cons; apply: Hd.
  - move: (Hd [::] [::x])=>/=->.
    by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
  move: (Hd [::] [::x])=>/=->.
  rewrite cats1 all_rcons /= Ho /=.
  by apply/sub_all/Ha=>z /= Hx; apply/le_trans/Ho.
apply/andP; split.
- move: (Hd [::] [::x])=>/=->.
  by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
by case: (IH b xs id)=>+ _; apply.
Qed.

Lemma sorted_runs xs : all (sorted <=%O) (runs xs).
Proof. by case: xs=>//=x xs; case: (sorted_runs_asc_desc x [::] xs id). Qed.

Lemma sorted_nmsort xs : sorted <=%O (nmsort xs).
Proof. by rewrite /nmsort; apply/sorted_merge_all/sorted_runs. Qed.

(* Running Time Analysis *)

Fixpoint C_runs_fix a xs : nat :=
  if xs is b::bs
    then (if b < a then C_desc b bs else C_asc b bs).+1
    else 0
with C_asc a xs : nat :=
  if xs is b::bs
    then (if a <= b then C_asc b bs else C_runs_fix b bs).+1
    else 0
with C_desc a xs : nat :=
  if xs is b::bs
     then (if b < a then C_desc b bs else C_runs_fix b bs).+1
     else 0.

Definition C_runs xs : nat :=
  if xs is x::xs' then C_runs_fix x xs' else 0.

Definition C_nmsort xs : nat :=
  C_runs xs + C_merge_all (runs xs).

Lemma C_merge_adj_flat xss : C_merge_adj xss <= size (flatten xss).
Proof.
funelim (C_merge_adj xss)=>//=; rewrite catA !size_cat.
by apply: leq_add=>//; apply: C_merge_leq.
Qed.

Lemma merge_adj_flat xss :
  size (flatten (merge_adj xss)) = size (flatten xss).
Proof.
funelim (merge_adj xss)=>//=.
by rewrite catA !size_cat H size_merge size_cat.
Qed.

Lemma C_merge_adj_log2 xss :
  C_merge_all xss <= size (flatten xss) * up_log 2 (size xss).
Proof.
funelim (C_merge_all xss)=>//=; move: H; simp C_merge_adj merge_adj.
rewrite /= !size_cat merge_adj_flat size_merge_adj size_merge size_cat =>IH.
rewrite up_log2S //= mulnS !addnA; apply: leq_add=>//.
by apply/leq_add/C_merge_adj_flat/C_merge_leq.
Qed.

Lemma size_runs_asc_desc x xs ys xd :
      size (flatten (runs_fix x ys)) = (size ys).+1
  /\  size (flatten (desc x xs ys)) = (size xs + size ys).+1
  /\ (is_dlist xd ->
      size (flatten (asc x xd ys)) = (size (xd [::]) + size ys).+1).
Proof.
elim: ys x xs xd=>/=.
- move=>x xs xd; do!split; first by rewrite cats0 addn0.
  by move=>H; move: (H [::] [::x])=>/=; rewrite !cats0=>->; rewrite size_cat addn0 /= addn1.
move=>b bs IH x xs xd; do!split.
- case: ifP=>_.
  - by case: (IH b [::x] id)=>_ [+ _]; rewrite /= addnC addn1.
  case: (IH b [::x] (cons x))=>_ [_] /=; rewrite /= addnC addn1; apply.
  by move=>??; rewrite cat_cons.
- case: ifP=>_ /=.
  - by case: (IH b (x::xs) id)=>_ [+ _]; rewrite /= addSnnS.
  by case: (IH b xs xd)=>+ _; rewrite size_cat=>->.
move=>H; case: ifP=>_ /=.
- case: (IH b xs (xd \o cons x))=>_ [_] /=.
  move: (H [::] [::x])=>/=->; rewrite size_cat /= addnAC -addnA addn1; apply.
  by move=>?? /=; rewrite -cat_cons; apply: H.
move: (H [::] [::x])=>/=->; rewrite !size_cat /=.
by case: (IH b xs xd)=>+ _; rewrite addnAC addn1=>->.
Qed.

Lemma size_runs xs : size (flatten (runs xs)) = size xs.
Proof. by case: xs=>//=x xs; case: (size_runs_asc_desc x [::] xs id). Qed.

Lemma size_runs_asc_desc_leq x xs ys xd :
      (size (runs_fix x ys) <= (size ys).+1)%N
  /\  (size (desc x xs ys) <= (size ys).+1)%N
  /\ (is_dlist xd ->
      (size (asc x xd ys) <= (size ys).+1)%N).
Proof.
elim: ys x xs xd=>//= b bs IH x xs xd; do!split.
- case: ifP=>_.
  - by apply: leqW; case: (IH b [::x] id)=>_ [+ _].
  apply: leqW; case: (IH b [::x] (cons x))=>_ [_]; apply.
  by move=>??; rewrite cat_cons.
- case: ifP=>_ /=.
  - by apply: leqW; case: (IH b (x::xs) id)=>_ [+ _].
  by rewrite ltnS; case: (IH b xs xd)=>+ _ /=.
move=>H; case: ifP=>_ /=.
- apply: leqW; case: (IH b xs (xd \o cons x))=>_ [_] /=; apply.
  by move=>?? /=; rewrite -cat_cons; apply: H.
by rewrite ltnS; case: (IH b xs xd)=>+ _.
Qed.

Lemma size_runs_leq xs : (size (runs xs) <= size xs)%N.
Proof. by case: xs=>//=x xs; case: (size_runs_asc_desc_leq x [::] xs id). Qed.

Lemma C_size_runs_asc_desc_leq x ys :
     (C_runs_fix x ys <= size ys)%N
  /\ (C_desc x ys <= size ys)%N
  /\ (C_asc x ys <= size ys)%N.
Proof.
elim: ys x=>//=b bs IH x.
by do!split; case: ifP=>_; rewrite ltnS; case: (IH b)=>+ [].
Qed.

Lemma C_size_runs_leq xs : (C_runs xs <= (size xs).-1)%N.
Proof. by case: xs=>//=x xs; case: (C_size_runs_asc_desc_leq x xs). Qed.

Lemma C_merge_runs_leq xs n :
  size xs = n -> (C_merge_all (runs xs) <= n * up_log 2 n)%N.
Proof.
move=>H; apply: leq_trans; first by apply: C_merge_adj_log2.
rewrite size_runs H leq_mul2l; apply/orP.
case: n H=>[H|n H]; first by left.
right; apply: leq_up_log; rewrite -H.
by apply: size_runs_leq.
Qed.

Lemma C_nmsort_leq xs n :
  size xs = n -> (C_nmsort xs <= n + n * up_log 2 n)%N.
Proof.
move=>H; rewrite /C_nmsort; apply/leq_add/C_merge_runs_leq=>//.
apply: leq_trans; first by apply: C_size_runs_leq.
by rewrite H; exact: leq_pred.
Qed.

End NaturalMergeSort.

Section Stability.
Context {disp : unit} {T : eqType} {K : orderType disp}.
Implicit Types (xs ys : seq T).

(* Definition *)

Fixpoint insort_key (f : T -> K) x xs : seq T :=
  if xs is y :: xs' then
    if f x <= f y then x :: y :: xs' else y :: insort_key f x xs'
    else [:: x].

Fixpoint isort_key f xs :=
  if xs is x :: xs' then insort_key f x (isort_key f xs') else [::].

Lemma perm_insort_key f x xs : perm_eq (insort_key f x xs) (x :: xs).
Proof.
elim: xs=>//= y xs IH; case: (_ <= _)=>//.
rewrite -(perm_cons y) in IH.
apply: perm_trans; first by exact: IH.
by apply/permP=>/=?; rewrite addnCA.
Qed.

Lemma perm_isort_key f xs : perm_eq (isort_key f xs) xs.
Proof.
elim: xs=>//= x xs IH.
apply: perm_trans; first by apply: perm_insort_key.
by rewrite perm_cons.
Qed.

Lemma sorted_insort_key f a xs :
  sorted <=%O (map f (insort_key f a xs)) = sorted <=%O (map f xs).
Proof.
elim: xs=>//= x xs IH.
case H: (_ <= _)=>/=; first by rewrite H.
rewrite !le_path_sortedE !all_map (perm_all _ (perm_insort_key _ _ _)) /= IH.
suff: f x <= f a by move=>->.
by rewrite leNgt lt_neqAle H andbF.
Qed.

Lemma sorted_isort_key f xs : sorted <=%O (map f (isort_key f xs)).
Proof. by elim: xs=>//=x xs; rewrite sorted_insort_key. Qed.

Lemma insort_key_cons f a xs :
  all (fun x => f a <= f x) xs -> insort_key f a xs = a :: xs.
Proof. by case: xs=>//=x xs /andP [-> _]. Qed.

Lemma filter_not_insort_key (p : pred T) f x xs :
  ~~ p x -> filter p (insort_key f x xs) = filter p xs.
Proof.
move/negbTE=>Hp; elim: xs=>/=; first by rewrite Hp.
move=>y xs IH; case: ifP=>_ /=; first by rewrite Hp.
by rewrite IH.
Qed.

Lemma filter_insort_key (p : pred T) f x xs :
  sorted <=%O (map f xs) -> p x ->
  filter p (insort_key f x xs) = insort_key f x (filter p xs).
Proof.
move/[swap]=>Hp; elim: xs=>/=; first by rewrite Hp.
move=>y xs IH; rewrite le_path_sortedE =>/andP [Ha Hs].
case: ifP=>Hf /=.
- rewrite Hp; case: ifP=>/=; first by rewrite Hf.
  rewrite insort_key_cons // all_filter.
  rewrite all_map in Ha; apply/sub_all/Ha.
  by move=>z /= Hf2; apply/implyP=>_; apply/le_trans/Hf2.
by case: ifP=>/=; rewrite (IH Hs) // Hf.
Qed.

Lemma isort_key_stable f k xs :
  filter (fun y => f y == k) (isort_key f xs) = filter (fun y => f y == k) xs.
Proof.
elim: xs=>//=x xs IH; case: ifP; last first.
- by move/negbT=>Hk; rewrite filter_not_insort_key.
move=>Hk; rewrite filter_insort_key //; last by apply: sorted_isort_key.
rewrite IH insort_key_cons // all_filter (eq_in_all (a2:=predT)) ?all_predT //.
by move=>z _ /=; apply/implyP; move/eqP: Hk=>->/eqP->.
Qed.

End Stability.


Require Import
  HoTT.Classes.interfaces.abstract_algebra.

(** If [B] is a (bounded) lattice, then so is [A -> B], pointwise.
    This relies on functional extensionality. *)
Section contents.
  Context `{Funext}.

  Context {A B : Type}.
  Context `{BJoin : Join B}.
  Context `{BMeet : Meet B}.
  Context `{BBottom : Bottom B}.
  Context `{BTop : Top B}.

  Global Instance bot_fun : Bottom (A -> B)
    := fun _ => ⊥.

  Global Instance top_fun : Top (A -> B)
    := fun _ => ⊤.

  Global Instance join_fun : Join (A -> B) :=
    fun (f g : A -> B) (a : A) => (f a) ⊔ (g a).

  Global Instance meet_fun : Meet (A -> B) :=
    fun (f g : A -> B) (a : A) => (f a) ⊓ (g a).

  (** Try to solve some of the lattice obligations automatically *)
  Create HintDb lattice_hints.
  #[local]
  Hint Resolve
       associativity
       absorption
       commutativity | 1 : lattice_hints.
  Local Ltac reduce_fun := compute; intros; apply path_forall; intro.

  Global Instance lattice_fun `{!IsLattice B} : IsLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    1,4: apply associativity.
    1,3: apply commutativity.
    1,2: apply binary_idempotent.
    1,2: apply absorption.
  Defined.

  Instance boundedjoinsemilattice_fun
   `{!IsBoundedJoinSemiLattice B} :
    IsBoundedJoinSemiLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    * apply associativity.
    * apply left_identity.
    * apply right_identity.
    * apply commutativity.
    * apply binary_idempotent.
  Defined.

  Instance boundedmeetsemilattice_fun
   `{!IsBoundedMeetSemiLattice B} :
    IsBoundedMeetSemiLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    * apply associativity.
    * apply left_identity.
    * apply right_identity.
    * apply commutativity.
    * apply binary_idempotent.
  Defined.

  Global Instance boundedlattice_fun
   `{!IsBoundedLattice B} : IsBoundedLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun; apply absorption.
  Defined.
End contents.

#[export]
  Hint Resolve
       associativity
       absorption
       commutativity | 1 : lattice_hints.


Require Import HoTT.

Lemma lem_prop: forall A B, ~(A * B) -> IsHProp A -> IsHProp B -> IsHProp (A + B).
intros A B H H0 H1.
apply ishprop_sum; auto.
Qed.

Lemma merely_functorial: forall P Q, (P -> Q) -> merely P -> merely Q.
  intros P Q H.
  apply Trunc_rec.
  intro H0.
  apply tr.
  auto.
Defined.

Theorem thm7_2_2:
  forall X: Type, forall R: X -> X -> hProp,
  (forall x y, R x y -> x = y) -> IsHSet X.
Admitted.

Section ex_7_1.
  Proposition ex_7_1_q1: (forall A, merely A -> A) -> forall X, IsHSet X.
  Proof.
    intros H X.
    apply (thm7_2_2 X (fun x y => merely (x = y))).
    intros x y.
    apply H.
  Qed.
  Goal (forall A B (f: A -> B), (forall b, merely (hfiber f b)) -> (forall b, hfiber f b))
        -> forall X, IsHSet X.
  Proof.
    intros H X.
    apply ex_7_1_q1.
    intros A H0.
    generalize (H A Unit (fun _ => tt)); intro H1.
    unfold hfiber in H1.
    apply H1.
    induction b.
    apply merely_functorial with (P := A); auto.
    intro a.
    exists a.
    auto.
    exact tt.
  Qed.
End ex_7_1.

Section ex_7_7.
  Definition GLEM m n := forall (A: TruncType n),
    Trunc m (A + ~A).
  Definition LEM := forall (A: hProp), A + ~A.
  Goal forall m, GLEM (-1) m.+1 <-> LEM.
    induction m.
    split.
    intros H A.
    generalize (H A).
    intro H0.
    assert (IsHProp (A + ~A)).
    apply lem_prop.
    intro H1; destruct H1; auto.
  Admitted.
End ex_7_7.


(* Exercise 125 *)

Require Import BenB.

Variables A B C D : Prop.

(* Peirce's law *)

Theorem exercise_125 : ((A -> B) -> A) -> A.
Proof.
imp_i a1.
neg_e' (A) a2.
hyp a2.
imp_e (A -> B).
hyp a1.
imp_i a3.
neg_e A.
hyp a2.
hyp a3.
Qed.