From Coq Require Import Bool List ListSet.
Import ListNotations.

Require Import CasperCBC.Lib.Preamble.
Require Import CasperCBC.Lib.ListExtras.

(** * List set utility definitions and lemmas *)

Definition set_eq {A} (s1 s2 : set A) : Prop :=
  incl s1 s2 /\ incl s2 s1.

Lemma set_eq_extract_forall
  {A : Type}
  (l1 l2 : set A)
  : set_eq l1 l2 <-> forall a, (In a l1 <-> In a l2).
Proof.
  unfold set_eq. unfold incl. apply forall_and_commute.
Qed.

Lemma set_eq_empty
  {A}
  : forall (l : list A),
    set_eq l [] -> l = [].
Proof.
  intros.
  destruct l as [|hd tl].
  - reflexivity.
  - destruct H.
    spec H hd (in_eq hd tl).
    inversion H.
Qed.

Lemma set_eq_proj1 {A} : forall (s1 s2 : set A),
  set_eq s1 s2 ->
  incl s1 s2.
Proof.
  intros. destruct H. assumption.
Qed.

Lemma set_eq_proj2 {A} : forall (s1 s2 : set A),
  set_eq s1 s2 ->
  incl s2 s1.
Proof.
  intros. destruct H. assumption.
Qed.

Lemma set_eq_refl {A} : forall (s : list A), set_eq s s.
Proof.
  induction s;split; intro; intro; assumption.
Qed.

Lemma set_eq_comm {A} : forall s1 s2 : set A,
  set_eq s1 s2 <-> set_eq s2 s1.
Proof.
  intros; split; intro; destruct H; split; assumption.
Qed.

Lemma set_eq_tran {A} : forall s1 s2 s3 : set A,
  set_eq s1 s2 ->
  set_eq s2 s3 ->
  set_eq s1 s3.
Proof.
  intros. split; apply incl_tran with s2; apply H || apply H0.
Qed.

Lemma set_eq_cons {A} : forall (a : A) (s1 s2 : set A),
  set_eq s1 s2 ->
  set_eq (a :: s1) (a :: s2).
Proof.
  intros. split; intros x Hin; destruct Hin; subst
  ; (left; reflexivity) || (right; apply H; assumption).
Qed.

Lemma set_eq_Forall
  {A : Type}
  (s1 s2 : set A)
  (H12 : set_eq s1 s2)
  (P : A -> Prop)
  : Forall P s1 <-> Forall P s2.
Proof.
  split; intros H; rewrite Forall_forall in *; intros x Hx
  ; apply H; apply H12; assumption
  .
Qed.

Fixpoint set_eq_fn_rec `{EqDecision A} (s1 s2 : list A) : bool :=
  match s1 with
  | [] =>
    match s2 with
    | [] => true
    | _ => false
    end
  | h :: t => if in_dec decide_eq h s2 then set_eq_fn_rec t (set_remove decide_eq h s2) else false
  end.

Definition set_eq_fn `{EqDecision A} (s1 s2 : list A) : bool :=
  set_eq_fn_rec (nodup decide_eq s1) (nodup decide_eq s2).

Lemma set_eq_fn_rec_iff `{EqDecision A} : forall (s1 s2 : list A),
  NoDup s1 ->
  NoDup s2 ->
  set_eq s1 s2 <-> set_eq_fn_rec s1 s2 = true.
Proof.
  intros; split; intros.
  - generalize dependent s2. induction s1; intros; destruct s2; destruct H1.
    + reflexivity.
    + apply incl_empty in  H2. inversion H2.
    + apply incl_empty in  H1. inversion H1.
    + apply NoDup_cons_iff in H. destruct H.
      apply NoDup_cons_iff in H0. destruct H0.
      simpl. destruct (decide (a0 = a)); subst.
      * rewrite decide_True; try reflexivity.
        apply IHs1; try assumption.
        { split; intros x Hin.
          - destruct (H1 x); try (right; assumption); try assumption; subst.
            exfalso. apply H; assumption.
          - destruct (H2 x); try (right; assumption); try assumption; subst.
            exfalso. apply H0; assumption.
        }
      * { destruct (in_dec decide_eq a s2).
          - rewrite decide_False.
            + apply IHs1; try assumption.
              * apply NoDup_cons_iff.
                { split.
                  - intro. apply set_remove_iff in H5; try assumption.
                    apply H0. destruct H5; assumption.
                  - apply set_remove_nodup. assumption.
                }
              * { split; intros x Hin.
                  - destruct (decide (x = a0)); subst; try (left; reflexivity).
                    right. apply set_remove_iff; try assumption.
                    split.
                    + destruct (H1 x); try assumption; try (right; assumption); subst.
                      exfalso. apply n0; reflexivity.
                    + intro; subst. apply H; assumption.
                  - destruct Hin; subst.
                    + destruct (H2 x); try assumption; try (left; reflexivity); subst.
                      exfalso; apply n; reflexivity.
                    + apply set_remove_iff in H5; try assumption. destruct H5.
                      destruct (H2 x); try assumption; try (right; assumption); subst.
                      exfalso; apply H6; reflexivity.
                }
            + intro; subst; apply n; reflexivity.
          - exfalso. apply n0. destruct (H1 a); try assumption; try (left; reflexivity); subst.
            exfalso; apply n; reflexivity.
        }
  - generalize dependent s2. induction s1; intros; simpl in H1; destruct s2; try discriminate.
    + split; apply incl_refl.
    + destruct (in_dec decide_eq a (a0 :: s2)); try discriminate.
      apply IHs1 in H1; destruct H1
      ; try (split; intros x Hin; destruct Hin as [Heq | Hin]; subst; try assumption).
      * apply H1 in Hin. apply set_remove_iff in Hin; try assumption. destruct Hin; assumption.
      * destruct (decide (x = a)); subst; try (left; reflexivity).
        right. apply H2. apply set_remove_iff; try assumption. split; try assumption.
        left; reflexivity.
      * destruct (decide (x = a)); subst; try (left; reflexivity).
        right. apply H2. apply set_remove_iff; try assumption. split; try assumption.
        right; assumption.
      * apply NoDup_cons_iff in H. destruct H; assumption.
      * apply set_remove_nodup. assumption.
Qed.

Lemma set_eq_functional `{EqDecision A} :
  @PredicateFunction2 _ (set A) set_eq set_eq_fn.
Proof.
  intros s1 s2. split; intros.
  - unfold set_eq_fn. apply set_eq_fn_rec_iff; try apply NoDup_nodup.
    destruct H as [H12 H21]. split; intros x Hin; apply nodup_In; apply nodup_In in Hin
    ; apply H12 || apply H21
    ; assumption.
  - apply set_eq_fn_rec_iff in H; try apply NoDup_nodup.
    destruct H as [H12 H21].
    split; intros x Hin; rewrite <- (nodup_In decide_eq); rewrite <- (nodup_In decide_eq) in Hin
    ; apply H12 || apply H21
    ; assumption.
Qed.

Instance set_eq_dec `{EqDecision A} : @RelDecision (set A) (set A) set_eq.
Proof.
intros s1 s2.
destruct (set_eq_fn s1 s2) eqn:Heq.
- left. apply set_eq_functional. assumption.
- right. intro. apply set_eq_functional in H. rewrite Heq in H. discriminate H.
Defined.

Lemma set_eq_singleton_iff `{EqDecision A} :
  forall (s1 : list A) (a : A),
  NoDup s1 ->
  set_eq s1 [a] <-> s1 = [a].
Proof.
  intros; split; intros.
  { destruct H0 as [Hincl1a Hincla1]. destruct s1.
    - exfalso. destruct (Hincla1 a). left. reflexivity.
    - destruct (incl_singleton _ a Hincl1a a0); try (left; reflexivity) .
      destruct s1; try reflexivity.
      destruct (incl_singleton _ a0 Hincl1a a); try (right; left; reflexivity) .
      exfalso. inversion H; subst; clear H. apply H2. left. reflexivity.
  }
  subst. apply set_eq_refl.
Qed.

Lemma set_eq_singleton `{EqDecision A} :
  forall (s1 : list A) (a : A),
  NoDup s1 ->
  set_eq s1 [a] -> s1 = [a].
Proof.
  intros. apply set_eq_singleton_iff; assumption.
Qed.

Lemma set_eq_singleton_rev `{EqDecision A} :
  forall (s1 : list A) (a : A),
  NoDup s1 ->
  s1 = [a] -> set_eq s1 [a].
Proof.
  intros. apply set_eq_singleton_iff; assumption.
Qed.

Lemma set_union_comm `{EqDecision A}  : forall (s1 s2 : list A),
  set_eq (set_union decide_eq s1 s2) (set_union decide_eq s2 s1).
Proof.
  intros; split; intro x; intros; apply set_union_iff in H; apply set_union_iff; destruct H;
  (left ; assumption) || (right; assumption).
Qed.

Lemma set_union_empty `{EqDecision A}  : forall (s1 s2 : list A),
  set_union decide_eq s1 s2 = nil ->
  s1 = nil /\ s2 = nil.
Proof.
  intros.
  destruct s2.
  - destruct (set_union_comm s1 nil). rewrite H in H1. destruct s1.
    + split; reflexivity.
    + simpl in H1. destruct (H1 a). apply set_add_intro. left. reflexivity.
  - simpl in H. assert (@incl A nil nil); try apply incl_refl.
    rewrite <- H in H0 at 1. destruct (H0 a). apply set_add_intro. left. reflexivity.
Qed.

Lemma set_union_incl_left `{EqDecision A}  : forall (s1 s2 : list A),
  incl s1 (set_union decide_eq s1 s2).
Proof.
  intros; intros x H; apply set_union_intro.
  left; assumption.
Qed.

Lemma set_union_incl_right `{EqDecision A}  : forall (s1 s2 : list A),
  incl s2 (set_union decide_eq s1 s2).
Proof.
  intros; intros x H; apply set_union_intro.
  right; assumption.
Qed.

Lemma set_union_incl_iterated `{EqDecision A}  : forall ss (s : list A),
  In s ss ->
  incl s (fold_right (set_union decide_eq) nil ss).
Proof.
  induction ss; intros.
  - inversion H.
  - simpl. destruct H.
    + subst. apply set_union_incl_left.
    + apply IHss in H. apply incl_tran with (fold_right (set_union decide_eq) [] ss); try assumption.
      apply set_union_incl_right.
Qed.

Lemma set_union_iterated_nodup `{EqDecision A}
  (ss : list (list A))
  (H : forall s, In s ss -> NoDup s) :
  NoDup (fold_right (set_union decide_eq) nil ss).
Proof.
  intros.
  generalize dependent ss.
  induction ss.
  - intros. simpl. apply NoDup_nil.
  - intros.
    simpl.
    apply set_union_nodup.
    specialize (H a).
    apply H.
    intuition.
    apply IHss.
    intros.
    specialize (H s).
    spec H.
    simpl.
    right.
    assumption.
    assumption.
Qed.

Lemma set_union_in_iterated
  `{EqDecision A}
  (ss : list (set A))
  (a : A)
  : In a (fold_right (set_union decide_eq) nil ss)
  <-> Exists (fun s => In a s) ss.
Proof.
  rewrite Exists_exists.
  induction ss; split; simpl.
  - intro H; inversion H.
  - intros [x [Hin _]]; inversion Hin.
  - intro Hin. apply set_union_iff in Hin.
    destruct Hin as [Hina0 | Hinss].
    + exists a0. split; try assumption. left. reflexivity.
    + apply IHss in Hinss. destruct Hinss as [x [Hinss Hinx]].
      exists x. split; try assumption.
      right. assumption.
  - rewrite set_union_iff.
    intros [x [[Heqa0 | Hinss] Hinx]]; subst.
    + left. assumption.
    + right. apply IHss.
      exists x. split; assumption.
Qed.

Lemma set_union_iterated_incl
  `{EqDecision A}
  (ss ss': list (set A))
  (Hincl : incl ss ss')
  :
  incl
  (fold_right (set_union decide_eq) nil ss)
  (fold_right (set_union decide_eq) nil ss').
Proof.
  unfold incl.
  intros.
  apply set_union_in_iterated in H.
  apply set_union_in_iterated.
  rewrite Exists_exists in *.
  destruct H as [x Heqx].
  exists x.
  unfold incl in Hincl.
  intuition.
Qed.

Lemma set_union_empty_left `{EqDecision A}  : forall (s : list A),
  NoDup s ->
  set_eq (set_union decide_eq nil s) s.
Proof.
  intros. split; intros x Hin.
  - apply set_union_elim in Hin. destruct Hin.
    + inversion H0.
    + assumption.
  - apply set_union_intro. right. assumption.
Qed.

Lemma map_set_eq {A B} (f : B -> A) : forall s s',
  set_eq s s' ->
  set_eq (map f s) (map f s').
Proof.
  split; apply map_incl; apply H.
Qed.

Lemma set_map_nodup {A B} `{EqDecision A} (f : B -> A) : forall (s : set B),
  NoDup (set_map decide_eq f s).
Proof.
  induction s; simpl; try constructor.
  apply set_add_nodup. assumption.
Qed.

Lemma set_map_in {A B} `{EqDecision A} (f : B -> A) : forall x s,
  In x s ->
  In (f x) (set_map decide_eq f s).
Proof.
  induction s; intros; inversion H; subst; clear H; simpl.
  - apply set_add_intro2. reflexivity.
  - apply set_add_intro1. apply IHs. assumption.
Qed.

Lemma set_map_exists {A B} `{EqDecision A} (f : B -> A) : forall y s,
  In y (set_map decide_eq f s) <->
  exists x, In x s /\ f x = y.
Proof.
  intros.
  induction s; split; intros; simpl in H.
  - inversion H.
  - destruct H as [_ [F _]]. inversion F.
  - apply set_add_iff in H. destruct H as [Heq | Hin]; subst.
    + exists a. split; try reflexivity. left; reflexivity.
    + apply IHs in Hin. destruct Hin as [x [Hin Heq]]; subst.
      exists x. split; try reflexivity. right; assumption.
  - destruct H as [x [[Heq | Hin] Heqf]]; subst; simpl; apply set_add_iff
    ; try (left; reflexivity) .
    right. apply IHs. exists x. split.
    + assumption.
    + reflexivity.
Qed.

Lemma set_map_incl {A B} `{EqDecision A} (f : B -> A) : forall s s',
  incl s s' ->
  incl (set_map decide_eq f s) (set_map decide_eq f s').
Proof.
  induction s; intros; intro msg; intros.
  - inversion H0.
  - simpl in H0. apply set_add_elim in H0. destruct H0.
    + subst. apply set_map_in. apply H. left. reflexivity.
    + apply IHs; try assumption. intros x; intros. apply H. right. assumption.
Qed.

Lemma set_map_eq {A B} `{EqDecision A} (f : B -> A) : forall s s',
  set_eq s s' ->
  set_eq (set_map decide_eq f s) (set_map decide_eq f s').
Proof.
  intros. split; destruct H; apply set_map_incl; assumption.
Qed.

Lemma set_map_singleton {A B} `{EqDecision A} (f : B -> A) : forall s a,
  set_map decide_eq f s = [a] ->
  forall b, In b s -> f b = a.
Proof.
  intros. apply (set_map_in f) in H0. rewrite H in H0. inversion H0.
  - subst. reflexivity.
  - exfalso. inversion H1.
Qed.

Lemma filter_set_add `{StrictlyComparable X} :
  forall (l : list X) (f : X -> bool) (x : X),
    f x = false ->
    filter f l = filter f (set_add compare_eq_dec x l).
Proof.
  induction l as [|hd tl IHl]; intros f x H_false.
  - simpl. rewrite H_false. reflexivity.
  - simpl. spec IHl f x H_false.
    destruct (compare_eq_dec x hd).
    + subst. rewrite H_false.
      simpl. rewrite H_false. reflexivity.
    + case_eq (f hd); intro H_eq;
      simpl; rewrite H_eq; rewrite <- IHl; reflexivity.
Qed.

Lemma set_add_ignore `{StrictlyComparable X} :
  forall (l : list X) (x : X),
    In x l ->
    set_add compare_eq_dec x l = l.
Proof.
  induction l as [|hd tl IHl]; intros x H_in.
  - inversion H_in.
  - inversion H_in.
    + subst. simpl.
      destruct (compare_eq_dec x x).
      reflexivity.
      contradiction.
    + spec IHl x H0. simpl.
      destruct (compare_eq_dec x hd).
      reflexivity.
      rewrite IHl. reflexivity.
Qed.

Lemma set_add_new `{EqDecision A}:
  forall (x:A) l,
    ~In x l -> set_add decide_eq x l = l++[x].
Proof.
  induction l.
  - reflexivity.
  - simpl.
    destruct (decide (x = a)).
    + intro H_not_in. exfalso. apply H_not_in. left. symmetry. assumption.
    + intro H_not_in.
      rewrite IHl by tauto.
      reflexivity.
Qed.

Lemma set_remove_not_in `{EqDecision A} : forall x (s : list A),
  ~ In x s ->
  set_remove decide_eq x s = s.
Proof.
  induction s; intros.
  - reflexivity.
  - simpl. apply not_in_cons in H.  destruct H.
    destruct (decide (x = a)); [congruence|].
    rewrite (IHs H0). reflexivity.
Qed.

Lemma set_remove_elim `{EqDecision A} : forall x (s : list A),
  NoDup s -> ~ In x (set_remove decide_eq x s).
Proof.
  intros. intro. apply set_remove_iff in H0; try assumption.
  destruct H0. apply H1. reflexivity.
Qed.

Lemma set_remove_first `{EqDecision A} : forall x y (s : list A),
  x = y -> set_remove decide_eq x (y::s) = s.
Proof.
  intros. destruct (decide (x = y)) eqn:Hcmp; simpl; rewrite Hcmp; try reflexivity.
  exfalso. apply n. assumption.
Qed.

Lemma set_remove_nodup_1 `{EqDecision A} : forall x (s : list A),
  NoDup (set_remove decide_eq x s) ->
  ~ In x (set_remove decide_eq x s) ->
  NoDup s.
Proof.
  induction s; intros.
  - constructor.
  - simpl in H0 . destruct (decide (x = a)).
    + subst. simpl in H. rewrite decide_True in H; auto. constructor; assumption.
    + apply not_in_cons in H0. destruct H0. simpl in H.
      rewrite decide_False in H; auto.
      inversion H; subst.
      specialize (IHs H5 H1).
      constructor; auto.
      intro; contradict H4.
      apply set_remove_3; congruence.
Qed.

Lemma set_remove_in_iff `{EqDecision A} :  forall x y (s : list A),
  NoDup s ->
  In y s ->
  In x s <-> x = y \/ In x (set_remove decide_eq y s).
Proof.
  intros. split; intros.
  - destruct (decide (x = y)).
    + left. assumption.
    + right. apply set_remove_3; assumption.
  - destruct H1 as [Heq | Hin].
    + subst; assumption.
    + apply set_remove_1 in Hin. assumption.
Qed.

Lemma set_remove_length
  `{EqDecision A}
  (x : A)
  (s : set A)
  (Hx : In x s)
  : length s = S (length (set_remove decide_eq x s)).
Proof.
  generalize dependent x. induction s; intros; inversion Hx; subst.
  - rewrite set_remove_first;  reflexivity.
  - simpl. f_equal.
    destruct (decide (x = a)); try reflexivity.
    apply IHs. assumption.
Qed.

Lemma set_eq_remove `{EqDecision A} : forall x (s1 s2 : list A),
  NoDup s1 ->
  NoDup s2 ->
  set_eq s1 s2 ->
  set_eq (set_remove decide_eq x s1) (set_remove decide_eq x s2).
Proof.
  intros.
  destruct H1. split; intros a Hin
  ; apply set_remove_iff; try assumption
  ; apply set_remove_iff in Hin; try assumption; destruct Hin
  ; split; try assumption
  .
  - apply H1. assumption.
  - apply H2. assumption.
Qed.

Lemma incl_remove_union  `{EqDecision A} : forall x (s1 s2 : list A),
  NoDup s1 ->
  NoDup s2 ->
  incl
    (set_remove decide_eq x (set_union decide_eq s1 s2))
    (set_union decide_eq s1 (set_remove decide_eq x s2)).
Proof.
  intros. intros y Hin. apply set_remove_iff in Hin.
  - apply set_union_intro. destruct Hin. apply set_union_elim in H1.
    destruct H1; try (left; assumption).
    right. apply set_remove_3; assumption.
  - apply set_union_nodup; assumption.
Qed.

Lemma set_eq_remove_union_in  `{EqDecision A} : forall x (s1 s2 : list A),
  NoDup s1 ->
  NoDup s2 ->
  In x s1 ->
  set_eq
    (set_union decide_eq s1 (set_remove decide_eq x s2))
    (set_union decide_eq s1 s2).
Proof.
  split; intros msg Hin; apply set_union_iff; apply set_union_iff in Hin
  ; destruct Hin; try (left; assumption)
  .
  - apply set_remove_iff in H2; try assumption. destruct H2. right. assumption.
  - destruct (decide (msg = x)).
    + subst. left. assumption.
    + right. apply set_remove_iff; try assumption. split; assumption.
Qed.

Lemma set_eq_remove_union_not_in  `{EqDecision A} : forall x (s1 s2 : list A),
  NoDup s1 ->
  NoDup s2 ->
  ~ In x s1 ->
  set_eq
    (set_union decide_eq s1 (set_remove decide_eq x s2))
    (set_remove decide_eq x (set_union decide_eq s1 s2)).
Proof.
  intros.
  assert (HnodupUs1s2 := H0).
  apply (set_union_nodup decide_eq H) in HnodupUs1s2.
  split; intros msg Hin.
  - apply set_remove_iff; try assumption.
    apply set_union_iff in Hin.
    destruct Hin; split.
    + apply set_union_iff. left. assumption.
    + intro; subst. apply H1. assumption.
    + apply set_remove_iff in H2; try assumption.
      destruct H2. apply set_union_iff. right. assumption.
    + intro; subst.
      apply set_remove_iff in H2; try assumption.
      destruct H2. apply H3. reflexivity.
  - apply set_union_iff; try assumption.
    apply set_remove_iff in Hin; try assumption.
    destruct Hin. apply set_union_iff in H2.
    destruct H2; try (left; assumption).
    right. apply set_remove_iff; try assumption.
    split; assumption.
Qed.

Lemma diff_app_nodup `{EqDecision A} : forall (s1 s2 : list A),
  NoDup s1 ->
  NoDup s2 ->
  NoDup ((set_diff decide_eq s1 s2) ++ s2).
Proof.
  intros.
  apply nodup_append; try assumption.
  - apply set_diff_nodup; try assumption.
  - intros. apply (set_diff_elim2 decide_eq a s1); assumption.
  - intros. intro. apply set_diff_iff in H2. destruct H2.
    apply H3. assumption.
Qed.

Lemma add_remove_inverse `{EqDecision X}:
  forall (lv : list X) (v : X),
    ~ In v lv ->
    set_remove decide_eq v (set_add decide_eq v lv) = lv.
Proof.
  induction lv as [|hd tl IHlv]; intros.
  - simpl.
    rewrite decide_True; congruence.
  - simpl. destruct (decide (v = hd)).
    subst. exfalso; apply H.
    apply in_eq.
    spec IHlv v. spec IHlv.
    intro Habsurd. apply H.
    right; assumption.
    rewrite <- IHlv at 2.
    simpl.
    destruct (decide (v = hd)).
    contradiction.
    reflexivity.
Qed.

Lemma set_union_iterated_empty `{EqDecision A} :
   forall ss,
   (forall (s : list A),
   In s ss -> s = []) -> (fold_right (set_union decide_eq) nil ss) = [].
Proof.
   intros.
   induction ss.
   - simpl.
     reflexivity.
   - simpl.
     assert (fold_right (set_union decide_eq) [] ss = []). {
        apply IHss.
        simpl in H.
        intros.
        specialize (H s).
        apply H.
        right.
        assumption.
     }
     rewrite H0.
     assert (a = []). {
      specialize (H a).
      apply H.
      intuition.
     }
  rewrite H1.
  simpl.
  reflexivity.
Qed.

(** For each element X of l1, exactly one occurrence of X is removed
   from l2. If no such occurrence exists, nothing happens. *)

Definition set_remove_list `{EqDecision A} (l1 l2 : list A) : list A :=
  fold_right (set_remove decide_eq) l2 l1.

Example set_remove_list1 : set_remove_list [3;1;3] [1;1;2;3;3;3;3] = [1;2;3;3].
Proof. intuition. Qed.

Example set_remove_list2 : set_remove_list [4] [1;2;3] = [1;2;3].
Proof. intuition. Qed.

Lemma set_remove_list_1
  `{EqDecision A}
  (a : A)
  (l1 l2 : list A)
  (Hin : In a (set_remove_list l1 l2)) :
  In a l2.
Proof.
  unfold set_remove_list in Hin.
  induction l1.
  - simpl in Hin; intuition.
  - simpl in Hin.
    apply set_remove_1 in Hin.
    apply IHl1 in Hin.
    assumption.
Qed.

Definition forallb_false {A}
  (l : list A)
  (Hne : l <> [])
  (f : A -> bool) :
  forallb f l = false ->
  exists (a : A), In a l /\ (f a) = false.
Proof.
  intros.
  induction l;[congruence|].
  simpl in H.
  destruct (f a) eqn : eqfa.
  - simpl in H.
    destruct l.
    + simpl in H. congruence.
    + spec IHl. congruence.
      specialize (IHl H).
      destruct IHl as [a' [Hina' Heqa']].
      exists a'. intuition.
  - exists a. intuition.
Qed.

(* Returns all elements X of l such that X does not compare less
   than any other element w.r.t to the preceeds relation *)

Definition get_maximal_elements
  `(preceeds : A -> A -> bool)
  (l : list A)
  : list A :=
  filter (fun a => forallb (fun b => negb (preceeds a b)) l) l.

Example get_maximal_elements1: get_maximal_elements Nat.ltb [1; 4; 2; 4] = [4;4].
Proof. intuition. Qed.

Example get_maximal_elements2 : get_maximal_elements Nat.leb [1; 4; 2; 4] = [].
Proof. intuition. Qed.

Lemma set_prod_nodup `(s1: set A) `(s2: set B):
  NoDup s1 ->
  NoDup s2 ->
  NoDup (set_prod s1 s2).
Proof.
  intros Hs1 HS2.
  induction Hs1.
  + constructor.
  + simpl.
    apply nodup_append.
    * apply FinFun.Injective_map_NoDup;[|assumption].
      intros y1 y2.
      apply (f_equal snd).
    * assumption.
    * intros [a b].
      rewrite in_map_iff.
      intros [_ [[= <- _] _]].
      rewrite in_prod_iff.
      tauto.
    * intros [a b].
      rewrite in_prod_iff.
      intros [Ha _].
      rewrite in_map_iff.
      intros [_ [[= Hax _] _]].
      congruence.
Qed.

(** An alternative to [set_diff].
    Unlike [set_diff], the result may contain
    duplicates if the first argument list <<l>> does.

    This definition exists to make proving
    [len_set_diff_decrease] more convenient,
    because <<length>> of <<filter>> can be simplified
    step by step while doing induction over <<l>>.
 *)
Definition set_diff_filter `{EqDecision A} (l r : list A) :=
  filter (fun a => if in_dec decide_eq a r then false else true) l.

(**
   The characteristic membership property, parallel to
   [set_diff_iff].
 *)
Lemma set_diff_filter_iff `{EqDecision A} (a:A) l r:
  In a (set_diff_filter l r) <-> (In a l /\ ~In a r).
Proof.
  induction l;simpl.
  - tauto.
  - destruct (in_dec decide_eq a0 r) as [H|H];simpl;rewrite IHl;
      clear -H;intuition congruence.
Qed.

Lemma set_diff_filter_nodup `{EqDecision A} (l r:list A):
  NoDup l -> NoDup (set_diff_filter l r).
Proof (@NoDup_filter _ _ _).

(**
   Prove that subtracting a superset cannot produce
   a smaller result.
   This lemma is used to prove [len_set_diff_decrease].
 *)
Lemma len_set_diff_incl_le `{EqDecision A} (l a b: list A)
      (H_incl: forall x, In x b -> In x a):
  length (set_diff_filter l a) <= length (set_diff_filter l b).
Proof.
  induction l;[reflexivity|].
  simpl.
  destruct (in_dec decide_eq a0 a);destruct (in_dec decide_eq a0 b).
  - assumption.
  - simpl. apply le_S. assumption.
  - exfalso. apply n, H_incl, i.
  - simpl. apply le_n_S. assumption.
Qed.

(**
   Prove that strictly increasing the set to be subtracted,
   by adding an element actually found in <<l>> will decrease
   the size of the result.
 *)
Lemma len_set_diff_decrease `{EqDecision A} (new:A) (l a b: list A)
      (H_incl: forall x, In x b -> In x a)
      (H_new_is_new: In new a /\ ~In new b)
      (H_new_is_relevant: In new l):
  length (set_diff_filter l a) < length (set_diff_filter l b).
Proof.
  induction l;destruct H_new_is_relevant.
  - subst a0.
    simpl.
    destruct (in_dec decide_eq new a);[|exfalso;tauto].
    destruct (in_dec decide_eq new b);[exfalso;tauto|].
    simpl. unfold lt. apply le_n_S.
    apply len_set_diff_incl_le;assumption.
  - specialize (IHl H);clear H.
    simpl.
    destruct (in_dec decide_eq a0 a);destruct (in_dec decide_eq a0 b).
    + assumption.
    + simpl. apply le_n_S. apply len_set_diff_incl_le;assumption.
    + exfalso. apply n, H_incl, i.
    + simpl. apply Lt.lt_n_S. assumption.
Qed.

Lemma len_set_diff_map_set_add `{EqDecision B} (new:B) `{EqDecision A} (f: B -> A)
      (a: list B) (l: list A)
      (H_new_is_new: ~In (f new) (map f a))
      (H_new_is_relevant: In (f new) l):
  length (set_diff_filter l (map f (set_add decide_eq new a)))
  < length (set_diff_filter l (map f a)).
Proof.
  apply len_set_diff_decrease with (f new).
  - intro x. rewrite 2 in_map_iff.
    intros [x0 [Hx0 Hin]]. exists x0.
    rewrite set_add_iff. tauto.
  - split;[|assumption].
    apply in_map.
    apply set_add_iff.
    left. reflexivity.
  - assumption.
Qed.

Require Import Setoid.

Add Parametric Relation A : (set A) (@set_eq A)
 reflexivity proved by (@set_eq_refl A)
 transitivity proved by (@set_eq_tran A) as set_eq_rel.

Add Parametric Morphism A : (@In A)
  with signature @eq A ==> @set_eq A ==> iff as In_set_eq.
Proof.
  intros a l1 l2 H.
  split;apply H.
Qed.

Add Parametric Morphism A : (@In A)
  with signature @eq A ==> @incl A ==> Basics.impl as In_incl.
Proof. firstorder. Qed.

Lemma set_union_iterated_preserves_prop
  `{EqDecision A}
  (ss : list (set A))
  (P : A -> Prop)
  (Hp : forall (s : set A), forall (a : A), (In s ss /\ In a s) -> P a) :
  forall (a : A), In a (fold_right (set_union decide_eq) nil ss) -> P a.
Proof.
  intros.
  apply set_union_in_iterated in H. rewrite Exists_exists in H.
  destruct H as [s [Hins Hina]].
  apply Hp with (s := s).
  intuition.
Qed.

Lemma filter_set_eq `{EqDecision X}
   (l : list X)
   (f g : X -> bool)
   (resf := filter f l)
   (resg := filter g l) :
   set_eq resf resg -> resf = resg.
Proof.
  intros.
  unfold resf, resg in *.
  apply filter_ext_in. intros.
  unfold set_eq in H.
  destruct H as [H H'].
  unfold incl in *.
  specialize (H a). specialize (H' a).
  assert (f a = true <-> g a = true). {
    split; intros.
    - spec H. apply filter_In. intuition.
      apply filter_In in H. intuition.
    - spec H'. apply filter_In. intuition.
      apply filter_In in H'. intuition.
  }
  specialize (eq_true_iff_eq (f a) (g a) H1).
  intuition.
Qed.

Lemma filter_complement `{EqDecision X}
   (l : list X)
   (f f' : X -> bool)
   (g := (fun (x : X) => negb (f x)))
   (g' := (fun (x : X) => negb (f' x))) :
   filter f l = filter f' l <->
   filter g l = filter g' l.
Proof.
   split; intros.
   - specialize (ext_in_filter f f' l H) as Hext.
     apply filter_ext_in.
     intros.
     unfold g. unfold g'.
     specialize (Hext a H0).
     rewrite Hext. intuition.
   - specialize (ext_in_filter g g' l H) as Hext.
     apply filter_ext_in. intros.
     specialize (Hext a H0).
     unfold g in Hext.
     unfold g' in Hext.
     destruct (f a); destruct (f' a); (simpl in *; intuition congruence).
Qed.

Unset Implicit Arguments.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *)

From Coq Require Import ZArith Reals Lia.

Require Import Zaux Raux Defs Digits.

Section Float_prop.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Theorem Rcompare_F2R :
  forall e m1 m2 : Z,
  Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Z.compare m1 m2.
Proof.
intros e m1 m2.
unfold F2R. simpl.
rewrite Rcompare_mult_r.
apply Rcompare_IZR.
apply bpow_gt_0.
Qed.

(** Basic facts *)
Theorem le_F2R :
  forall e m1 m2 : Z,
  (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R ->
  (m1 <= m2)%Z.
Proof.
intros e m1 m2 H.
apply le_IZR.
apply Rmult_le_reg_r with (bpow e).
apply bpow_gt_0.
exact H.
Qed.

Theorem F2R_le :
  forall m1 m2 e : Z,
  (m1 <= m2)%Z ->
  (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R.
Proof.
intros m1 m2 e H.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply IZR_le.
Qed.

Theorem lt_F2R :
  forall e m1 m2 : Z,
  (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R ->
  (m1 < m2)%Z.
Proof.
intros e m1 m2 H.
apply lt_IZR.
apply Rmult_lt_reg_r with (bpow e).
apply bpow_gt_0.
exact H.
Qed.

Theorem F2R_lt :
  forall e m1 m2 : Z,
  (m1 < m2)%Z ->
  (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R.
Proof.
intros e m1 m2 H.
unfold F2R. simpl.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply IZR_lt.
Qed.

Theorem F2R_eq :
  forall e m1 m2 : Z,
  (m1 = m2)%Z ->
  (F2R (Float beta m1 e) = F2R (Float beta m2 e))%R.
Proof.
intros e m1 m2 H.
now apply (f_equal (fun m => F2R (Float beta m e))).
Qed.

Theorem eq_F2R :
  forall e m1 m2 : Z,
  F2R (Float beta m1 e) = F2R (Float beta m2 e) ->
  m1 = m2.
Proof.
intros e m1 m2 H.
apply Zle_antisym ;
  apply le_F2R with e ;
  rewrite H ;
  apply Rle_refl.
Qed.

Theorem F2R_Zabs:
  forall m e : Z,
   F2R (Float beta (Z.abs m) e) = Rabs (F2R (Float beta m e)).
Proof.
intros m e.
unfold F2R.
rewrite Rabs_mult.
rewrite <- abs_IZR.
simpl.
apply f_equal.
apply sym_eq; apply Rabs_right.
apply Rle_ge.
apply bpow_ge_0.
Qed.

Theorem F2R_Zopp :
  forall m e : Z,
  F2R (Float beta (Z.opp m) e) = Ropp (F2R (Float beta m e)).
Proof.
intros m e.
unfold F2R. simpl.
rewrite <- Ropp_mult_distr_l_reverse.
now rewrite opp_IZR.
Qed.

Theorem F2R_cond_Zopp :
  forall b m e,
  F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)).
Proof.
intros [|] m e ; unfold F2R ; simpl.
now rewrite opp_IZR, Ropp_mult_distr_l_reverse.
apply refl_equal.
Qed.

(** Sign facts *)
Theorem F2R_0 :
  forall e : Z,
  F2R (Float beta 0 e) = 0%R.
Proof.
intros e.
unfold F2R. simpl.
apply Rmult_0_l.
Qed.

Theorem eq_0_F2R :
  forall m e : Z,
  F2R (Float beta m e) = 0%R ->
  m = Z0.
Proof.
intros m e H.
apply eq_F2R with e.
now rewrite F2R_0.
Qed.

Theorem ge_0_F2R :
  forall m e : Z,
  (0 <= F2R (Float beta m e))%R ->
  (0 <= m)%Z.
Proof.
intros m e H.
apply le_F2R with e.
now rewrite F2R_0.
Qed.

Theorem le_0_F2R :
  forall m e : Z,
  (F2R (Float beta m e) <= 0)%R ->
  (m <= 0)%Z.
Proof.
intros m e H.
apply le_F2R with e.
now rewrite F2R_0.
Qed.

Theorem gt_0_F2R :
  forall m e : Z,
  (0 < F2R (Float beta m e))%R ->
  (0 < m)%Z.
Proof.
intros m e H.
apply lt_F2R with e.
now rewrite F2R_0.
Qed.

Theorem lt_0_F2R :
  forall m e : Z,
  (F2R (Float beta m e) < 0)%R ->
  (m < 0)%Z.
Proof.
intros m e H.
apply lt_F2R with e.
now rewrite F2R_0.
Qed.

Theorem F2R_ge_0 :
  forall f : float beta,
  (0 <= Fnum f)%Z ->
  (0 <= F2R f)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_le.
Qed.

Theorem F2R_le_0 :
  forall f : float beta,
  (Fnum f <= 0)%Z ->
  (F2R f <= 0)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_le.
Qed.

Theorem F2R_gt_0 :
  forall f : float beta,
  (0 < Fnum f)%Z ->
  (0 < F2R f)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_lt.
Qed.

Theorem F2R_lt_0 :
  forall f : float beta,
  (Fnum f < 0)%Z ->
  (F2R f < 0)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_lt.
Qed.

Theorem F2R_neq_0 :
 forall f : float beta,
  (Fnum f <> 0)%Z ->
  (F2R f <> 0)%R.
Proof.
intros f H H1.
apply H.
now apply eq_0_F2R with (Fexp f).
Qed.

Lemma Fnum_ge_0: forall (f : float beta),
  (0 <= F2R f)%R -> (0 <= Fnum f)%Z.
Proof.
intros f H.
case (Zle_or_lt 0 (Fnum f)); trivial.
intros H1; contradict H.
apply Rlt_not_le.
now apply F2R_lt_0.
Qed.

Lemma Fnum_le_0: forall (f : float beta),
  (F2R f <= 0)%R -> (Fnum f <= 0)%Z.
Proof.
intros f H.
case (Zle_or_lt (Fnum f) 0); trivial.
intros H1; contradict H.
apply Rlt_not_le.
now apply F2R_gt_0.
Qed.

(** Floats and bpow *)
Theorem F2R_bpow :
  forall e : Z,
  F2R (Float beta 1 e) = bpow e.
Proof.
intros e.
unfold F2R. simpl.
apply Rmult_1_l.
Qed.

Theorem bpow_le_F2R :
  forall m e : Z,
  (0 < m)%Z ->
  (bpow e <= F2R (Float beta m e))%R.
Proof.
intros m e H.
rewrite <- F2R_bpow.
apply F2R_le.
now apply (Zlt_le_succ 0).
Qed.

Theorem F2R_p1_le_bpow :
  forall m e1 e2 : Z,
  (0 < m)%Z ->
  (F2R (Float beta m e1) < bpow e2)%R ->
  (F2R (Float beta (m + 1) e1) <= bpow e2)%R.
Proof.
intros m e1 e2 Hm.
intros H.
assert (He : (e1 <= e2)%Z).
(* . *)
apply (le_bpow beta).
apply Rle_trans with (F2R (Float beta m e1)).
unfold F2R. simpl.
rewrite <- (Rmult_1_l (bpow e1)) at 1.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply IZR_le.
now apply (Zlt_le_succ 0).
now apply Rlt_le.
(* . *)
revert H.
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite bpow_plus.
unfold F2R. simpl.
rewrite <- (IZR_Zpower beta (e2 - e1)).
intros H.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rmult_lt_reg_r in H.
apply IZR_le.
apply Zlt_le_succ.
now apply lt_IZR.
apply bpow_gt_0.
now apply Zle_minus_le_0.
Qed.

Theorem bpow_le_F2R_m1 :
  forall m e1 e2 : Z,
  (1 < m)%Z ->
  (bpow e2 < F2R (Float beta m e1))%R ->
  (bpow e2 <= F2R (Float beta (m - 1) e1))%R.
Proof.
intros m e1 e2 Hm.
case (Zle_or_lt e1 e2); intros He.
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite bpow_plus.
unfold F2R. simpl.
rewrite <- (IZR_Zpower beta (e2 - e1)).
intros H.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rmult_lt_reg_r in H.
apply IZR_le.
rewrite (Zpred_succ (Zpower _ _)).
apply Zplus_le_compat_r.
apply Zlt_le_succ.
now apply lt_IZR.
apply bpow_gt_0.
now apply Zle_minus_le_0.
intros H.
apply Rle_trans with (1*bpow e1)%R.
rewrite Rmult_1_l.
apply bpow_le.
now apply Zlt_le_weak.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply IZR_le.
lia.
Qed.

Theorem F2R_lt_bpow :
  forall f : float beta, forall e',
  (Z.abs (Fnum f) < Zpower beta (e' - Fexp f))%Z ->
  (Rabs (F2R f) < bpow e')%R.
Proof.
intros (m, e) e' Hm.
rewrite <- F2R_Zabs.
destruct (Zle_or_lt e e') as [He|He].
unfold F2R. simpl.
apply Rmult_lt_reg_r with (bpow (-e)).
apply bpow_gt_0.
rewrite Rmult_assoc, <- 2!bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite <-IZR_Zpower. 2: now apply Zle_left.
now apply IZR_lt.
elim Zlt_not_le with (1 := Hm).
simpl.
assert (H: (e' - e < 0)%Z) by lia.
clear -H.
destruct (e' - e)%Z ; try easy.
apply Zabs_pos.
Qed.

Theorem F2R_change_exp :
  forall e' m e : Z,
  (e' <= e)%Z ->
  F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e')) e').
Proof.
intros e' m e He.
unfold F2R. simpl.
rewrite mult_IZR, IZR_Zpower, Rmult_assoc.
apply f_equal.
pattern e at 1 ; replace e with (e - e' + e')%Z by ring.
apply bpow_plus.
now apply Zle_minus_le_0.
Qed.

Theorem F2R_prec_normalize :
  forall m e e' p : Z,
  (Z.abs m < Zpower beta p)%Z ->
  (bpow (e' - 1)%Z <= Rabs (F2R (Float beta m e)))%R ->
  F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e' + p)) (e' - p)).
Proof.
intros m e e' p Hm Hf.
assert (Hp: (0 <= p)%Z).
destruct p ; try easy.
now elim (Zle_not_lt _ _ (Zabs_pos m)).
(* . *)
replace (e - e' + p)%Z with (e - (e' - p))%Z by ring.
apply F2R_change_exp.
cut (e' - 1 < e + p)%Z. lia.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hf).
rewrite <- F2R_Zabs, Zplus_comm, bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- IZR_Zpower.
now apply IZR_lt.
exact Hp.
Qed.

(** Floats and mag *)
Theorem mag_F2R_bounds :
  forall x m e, (0 < m)%Z ->
  (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R ->
  mag beta x = mag beta (F2R (Float beta m e)) :> Z.
Proof.
intros x m e Hp (Hx,Hx2).
destruct (mag beta (F2R (Float beta m e))) as (ex, He).
simpl.
apply mag_unique.
assert (Hp1: (0 < F2R (Float beta m e))%R).
now apply F2R_gt_0.
specialize (He (Rgt_not_eq _ _ Hp1)).
rewrite Rabs_pos_eq in He. 2: now apply Rlt_le.
destruct He as (He1, He2).
assert (Hx1: (0 < x)%R).
now apply Rlt_le_trans with (2 := Hx).
rewrite Rabs_pos_eq. 2: now apply Rlt_le.
split.
now apply Rle_trans with (1 := He1).
apply Rlt_le_trans with (1 := Hx2).
now apply F2R_p1_le_bpow.
Qed.

Theorem mag_F2R :
  forall m e : Z,
  m <> Z0 ->
  (mag beta (F2R (Float beta m e)) = mag beta (IZR m) + e :> Z)%Z.
Proof.
intros m e H.
unfold F2R ; simpl.
apply mag_mult_bpow.
now apply IZR_neq.
Qed.

Theorem Zdigits_mag :
  forall n,
  n <> Z0 ->
  Zdigits beta n = mag beta (IZR n).
Proof.
intros n Hn.
destruct (mag beta (IZR n)) as (e, He) ; simpl.
specialize (He (IZR_neq _ _ Hn)).
rewrite <- abs_IZR in He.
assert (Hd := Zdigits_correct beta n).
assert (Hd' := Zdigits_gt_0 beta n).
apply Zle_antisym ; apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
rewrite <- IZR_Zpower by lia.
now apply IZR_le.
apply Rle_lt_trans with (1 := proj1 He).
rewrite <- IZR_Zpower by lia.
now apply IZR_lt.
Qed.

Theorem mag_F2R_Zdigits :
  forall m e, m <> Z0 ->
  (mag beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z.
Proof.
intros m e Hm.
rewrite mag_F2R with (1 := Hm).
apply (f_equal (fun v => Zplus v e)).
apply sym_eq.
now apply Zdigits_mag.
Qed.

Theorem mag_F2R_bounds_Zdigits :
  forall x m e, (0 < m)%Z ->
  (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R ->
  mag beta x = (Zdigits beta m + e)%Z :> Z.
Proof.
intros x m e Hm Bx.
apply mag_F2R_bounds with (1 := Hm) in Bx.
rewrite Bx.
apply mag_F2R_Zdigits.
now apply Zgt_not_eq.
Qed.

Theorem float_distribution_pos :
  forall m1 e1 m2 e2 : Z,
  (0 < m1)%Z ->
  (F2R (Float beta m1 e1) < F2R (Float beta m2 e2) < F2R (Float beta (m1 + 1) e1))%R ->
  (e2 < e1)%Z /\ (e1 + mag beta (IZR m1) = e2 + mag beta (IZR m2))%Z.
Proof.
intros m1 e1 m2 e2 Hp1 (H12, H21).
assert (He: (e2 < e1)%Z).
(* . *)
apply Znot_ge_lt.
intros H0.
elim Rlt_not_le with (1 := H21).
apply Z.ge_le in H0.
apply (F2R_change_exp e1 m2 e2) in H0.
rewrite H0.
apply F2R_le.
apply Zlt_le_succ.
apply (lt_F2R e1).
now rewrite <- H0.
(* . *)
split.
exact He.
rewrite (Zplus_comm e1), (Zplus_comm e2).
assert (Hp2: (0 < m2)%Z).
apply (gt_0_F2R m2 e2).
apply Rlt_trans with (2 := H12).
now apply F2R_gt_0.
rewrite <- 2!mag_F2R.
destruct (mag beta (F2R (Float beta m1 e1))) as (e1', H1).
simpl.
apply sym_eq.
apply mag_unique.
assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R).
rewrite <- (Z.abs_eq m1), F2R_Zabs.
apply H1.
apply Rgt_not_eq.
apply Rlt_gt.
now apply F2R_gt_0.
now apply Zlt_le_weak.
clear H1.
rewrite <- F2R_Zabs, Z.abs_eq.
split.
apply Rlt_le.
apply Rle_lt_trans with (2 := H12).
apply H2.
apply Rlt_le_trans with (1 := H21).
now apply F2R_p1_le_bpow.
now apply Zlt_le_weak.
apply sym_not_eq.
now apply Zlt_not_eq.
apply sym_not_eq.
now apply Zlt_not_eq.
Qed.

End Float_prop.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Basic facts about fibrations *)

Require Import HoTT.Basics HoTT.Types HProp EquivalenceVarieties.

Local Open Scope equiv_scope.
Local Open Scope path_scope.

(* ** Homotopy fibers *)

(** Paths in homotopy fibers can be constructed using [path_sigma] and [transport_paths_Fl]. *)

Definition equiv_path_hfiber {A B : Type} {f : A -> B} {y : B}
  (x1 x2 : hfiber f y)
: { q : x1.1 = x2.1 & x1.2 = ap f q @ x2.2 } <~> (x1 = x2).
Proof.
  refine (equiv_path_sigma _ _ _ oE _).
  refine (equiv_functor_sigma' 1 _).
  intros p; simpl.
  refine (_ oE equiv_moveR_Vp _ _ _).
  exact (equiv_concat_l (transport_paths_Fl _ _) _).
Defined.

Definition path_hfiber_uncurried {A B : Type} {f : A -> B} {y : B}
  {x1 x2 : hfiber f y}
: { q : x1.1 = x2.1 & x1.2 = ap f q @ x2.2 } -> (x1 = x2)
  := equiv_path_hfiber x1 x2.

Definition path_hfiber {A B : Type} {f : A -> B} {y : B}
  {x1 x2 : hfiber f y} (q : x1.1 = x2.1) (r : x1.2 = ap f q @ x2.2)
: x1 = x2
:= path_hfiber_uncurried (q;r).

(** If we rearrange this a bit, then it characterizes the fibers of [ap]. *)

Definition hfiber_ap {A B : Type} {f : A -> B} {x1 x2 : A}
           (p : f x1 = f x2)
: hfiber (ap f) p <~> ((x1 ; p) = (x2 ; 1) :> hfiber f (f x2)).
Proof.
  refine (equiv_path_hfiber (x1;p) (x2;1%path) oE _).
  unfold hfiber; simpl.
  refine (equiv_functor_sigma' 1 _); intros q.
  refine (_ oE equiv_path_inverse _ _).
  exact (equiv_concat_r (concat_p1 _)^ _).
Defined.

(** Homotopic maps have equivalent fibers. *)

Definition equiv_hfiber_homotopic
           {A B : Type} (f g : A -> B) (h : f == g) (b : B)
: hfiber f b <~> hfiber g b.
Proof.
  refine (Build_Equiv _ _ (fun fx => (fx.1 ; (h fx.1)^ @ fx.2)) _).
  refine (isequiv_adjointify _ (fun gx => (gx.1 ; (h gx.1) @ gx.2)) _ _);
    intros [a p]; simpl.
  - apply ap, concat_V_pp.
  - apply ap, concat_p_Vp.
Defined.

(** Commutative squares induce maps between fibers. *)

Definition functor_hfiber {A B C D}
           {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D}
           (p : k o f == g o h) (b : B)
: hfiber f b -> hfiber g (k b).
Proof.
  unshelve rapply @functor_sigma.
  - exact h.
  - intros a e; exact ((p a)^ @ ap k e).
Defined.

(** ** The 3x3 lemma *)

Definition hfiber_functor_hfiber {A B C D}
           {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D}
           (p : k o f == g o h) (b : B) (c : C) (q : g c = k b)
: hfiber (functor_hfiber p b) (c;q)
  <~> hfiber (functor_hfiber (fun x => (p x)^) c) (b;q^).
Proof.
  unfold hfiber, functor_hfiber, functor_sigma.
  refine (_ oE (equiv_sigma_assoc _ _)^-1).
  refine (equiv_sigma_assoc _ _ oE _).
  apply (equiv_functor_sigma' 1); intros a; cbn.
  refine (_ oE
         (equiv_functor_sigma'
            (P := fun r => { s : h a = c & s # ((p a)^ @ ap k r) = q })
            1 (fun r => equiv_path_sigma _
                          (h a; (p a)^ @ ap k r) (c; q)))^-1).
  refine (equiv_functor_sigma'
            (P := fun r => { s : f a = b & s # (((p a)^)^ @ ap g r) = q^ })
            1 (fun r => equiv_path_sigma _
                          (f a; ((p a)^)^ @ ap g r) (b; q^)) oE _).
  refine (equiv_sigma_symm _ oE _).
  refine (equiv_functor_sigma' 1 _); intros r.
  refine (equiv_functor_sigma' 1 _); intros s; cbn.
  refine (equiv_concat_l (transport_paths_Fl _ _) _ oE _).
  refine (_ oE (equiv_concat_l (transport_paths_Fl _ _) _)^-1).
  refine ((equiv_ap inverse _ _)^-1 oE _).
  refine (equiv_concat_r (inv_V q)^ _ oE _).
  apply equiv_concat_l.
  abstract (rewrite !inv_pp, !inv_V, concat_pp_p; reflexivity).
Defined.

(** ** Replacing a map with a fibration *)

Definition equiv_fibration_replacement  {B C} (f:C ->B):
  C <~> {y:B & hfiber f y}.
Proof.
  simple refine (Build_Equiv _ _ _ (Build_IsEquiv
               C {y:B & {x:C & f x = y}}
               (fun c => (f c; (c; idpath)))
               (fun c => c.2.1)
               _
               (fun c => idpath)
               _)).
  - intros [? [? []]]; reflexivity.
  - reflexivity.
Defined.

Definition hfiber_fibration {X} (x : X) (P:X->Type):
    P x <~> @hfiber (sigT P) X pr1 x.
Proof.
  simple refine (Build_Equiv _ _ _ (Build_IsEquiv
               (P x) { z : sigT P & z.1 = x }
               (fun Px => ((x; Px); idpath))
               (fun Px => transport P Px.2 Px.1.2)
               _
               (fun Px => idpath)
               _)).
  - intros [[] []]; reflexivity.
  - reflexivity.
Defined.

(** ** Exercise 4.4: The unstable octahedral axiom. *)

Section UnstableOctahedral.

  Context (n:trunc_index) {A B C} (f : A -> B) (g : B -> C).

  Definition hfiber_compose_map (b : B)
  : hfiber (g o f) (g b) -> hfiber g (g b)
    := fun x => (f x.1 ; x.2).

  Definition hfiber_hfiber_compose_map (b : B)
  : hfiber (hfiber_compose_map b) (b;1) <~> hfiber f b.
  Proof.
    unfold hfiber, hfiber_compose_map.
    refine (_ oE (equiv_sigma_assoc _ _)^-1).
    refine (equiv_functor_sigma' 1 _); intros a; simpl.
    refine (equiv_compose' (B := {p : g (f a) = g b & {q : f a = b & transport (fun y => g y = g b) q p = 1}}) _ _).
    - refine (_ oE equiv_sigma_symm _).
      apply equiv_sigma_contr; intros p.
      destruct p; simpl; exact _.
    - refine (equiv_functor_sigma' 1
                (fun p => (equiv_path_sigma _ _ _)^-1)).
  Defined.

  Definition hfiber_compose (c : C)
  : hfiber (g o f) c <~> { w : hfiber g c & hfiber f w.1 }.
  Proof.
    unfold hfiber.
    refine (equiv_sigma_assoc
              (fun x => g x = c) (fun w => {x : A & f x = w.1}) oE _).
    refine (equiv_functor_sigma' 1
             (fun b => equiv_sigma_symm (fun a p => f a = b)) oE _).
    refine (equiv_sigma_symm _ oE _).
    refine (equiv_functor_sigma' 1 _); intros a.
    refine (equiv_functor_sigma' 1
              (fun b => equiv_sigma_symm0 _ _) oE _); simpl.
    refine ((equiv_sigma_assoc' _ _)^-1 oE _).
    symmetry.
    exact (equiv_contr_sigma (fun (w:{b:B & f a = b}) => g w.1 = c)).
  Defined.

  Global Instance istruncmap_compose `{!IsTruncMap n g} `{!IsTruncMap n f}
    : IsTruncMap n (g o f).
  Proof.
    intros c.
    exact (trunc_equiv _ (hfiber_compose c)^-1).
  Defined.

End UnstableOctahedral.

(** ** Fibers of constant functions *)
Definition hfiber_constant A {B} (y y' : B)
  : hfiber (fun _ : A => y) y' <~> A * (y = y')
  := equiv_sigma_prod0 A (y = y').

Global Instance istruncmap_constant n {A B} `{!IsTrunc n A}
       (y : B) `{!forall y', IsTrunc n (y = y')}
  : IsTruncMap n (fun _ : A => y)
  := fun y' => _.

(** ** Fibers of [functor_sigma] *)

Definition hfiber_functor_sigma {A B} (P : A -> Type) (Q : B -> Type)
           (f : A -> B) (g : forall a, P a -> Q (f a))
           (b : B) (v : Q b)
: (hfiber (functor_sigma f g) (b; v)) <~>
  {w : hfiber f b & hfiber (g w.1) ((w.2)^ # v)}.
Proof.
  unfold hfiber, functor_sigma.
  equiv_via ({x : sigT P & {p : f x.1 = b & p # (g x.1 x.2) = v}}).
  { refine (equiv_functor_sigma' 1
             (fun x => (equiv_path_sigma Q _ _)^-1)). }
  refine (_ oE (equiv_sigma_assoc P _)^-1).
  equiv_via ({a:A & {q:f a = b & {p : P a & q # (g a p) = v}}}).
  { refine (equiv_functor_sigma' 1 (fun a => _)); simpl.
    refine (equiv_sigma_symm _). }
  refine (_ oE (equiv_sigma_assoc' _ _)).
  refine (equiv_functor_sigma' 1 _);
    intros [a p]; simpl.
  refine (equiv_functor_sigma' 1 _);
    intros u; simpl.
  apply equiv_moveL_transport_V.
Defined.

Global Instance istruncmap_functor_sigma n {A B P Q}
       (f : A -> B) (g : forall a, P a -> Q (f a))
       {Hf : IsTruncMap n f} {Hg : forall a, IsTruncMap n (g a)}
  : IsTruncMap n (functor_sigma f g).
Proof.
  intros [a b].
  exact (trunc_equiv _ (hfiber_functor_sigma _ _ _ _ _ _)^-1).
Defined.

(** Theorem 4.7.6 *)
Definition hfiber_functor_sigma_idmap {A} (P Q : A -> Type)
           (g : forall a, P a -> Q a)
           (b : A) (v : Q b)
: (hfiber (functor_sigma idmap g) (b; v)) <~>
   hfiber (g b) v.
Proof.
  refine (_ oE hfiber_functor_sigma P Q idmap g b v).
  exact (equiv_contr_sigma
           (fun (w:hfiber idmap b) => hfiber (g w.1) (transport Q (w.2)^ v))).
Defined.

Definition istruncmap_from_functor_sigma n {A P Q}
           (g : forall a : A, P a -> Q a)
           `{!IsTruncMap n (functor_sigma idmap g)}
  : forall a, IsTruncMap n (g a).
Proof.
  intros a v.
  exact (trunc_equiv' _ (hfiber_functor_sigma_idmap _ _ _ _ _)).
Defined.

Definition isequiv_from_functor_sigma {A} (P Q : A -> Type)
           (g : forall a, P a -> Q a)
           `{IsEquiv _ _ (functor_sigma idmap g)}
: forall (a : A), IsEquiv (g a).
Proof.
  intros a; apply isequiv_fcontr.
  apply istruncmap_from_functor_sigma.
  red; by apply fcontr_isequiv.
Defined.

(** Theorem 4.7.7 *)
Definition equiv_total_iff_equiv_fiberwise {A} (P Q : A -> Type)
           (g : forall a, P a -> Q a)
: IsEquiv (functor_sigma idmap g) <-> forall a, IsEquiv (g a).
Proof.
  split.
  - apply isequiv_from_functor_sigma.
  - intro H. apply isequiv_functor_sigma.
Defined.

(** ** Fibers of [functor_prod] *)
Definition hfiber_functor_prod {A B C D}
           (f : A -> B) (g : C -> D) y
  : hfiber (Prod.functor_prod f g) y <~> (hfiber f (fst y) * hfiber g (snd y)).
Proof.
  unfold Prod.functor_prod.
  srefine (equiv_adjointify _ _ _ _).
  - exact (fun x => ((fst x.1; ap fst x.2), (snd x.1; ap snd x.2))).
  - refine (fun xs => (((fst xs).1, (snd xs).1); _)).
    apply Prod.path_prod;simpl.
    + exact (fst xs).2.
    + exact (snd xs).2.
  - destruct y as [y1 y2]; intros [[x1 p1] [x2 p2]].
    simpl in *. destruct p1,p2. reflexivity.
  - intros [[x1 x2] p]. destruct p;cbn. reflexivity.
Defined.

Global Instance istruncmap_functor_prod n {A B C D}
       (f : A -> B) (g : C -> D)
       `{!IsTruncMap n f} `{!IsTruncMap n g}
  : IsTruncMap n (Prod.functor_prod f g).
Proof.
  intros y.
  exact (trunc_equiv _ (hfiber_functor_prod _ _ _)^-1).
Defined.

(** ** [IsTruncMap n.+1 f <-> IsTruncMap n (ap f)] *)
Global Instance istruncmap_ap {A B} n (f:A -> B) `{!IsTruncMap n.+1 f}
  : forall x y, IsTruncMap n (@ap _ _ f x y)
  := fun x x' y =>
       trunc_equiv' _ (hfiber_ap y)^-1.

Definition istruncmap_from_ap {A B} n (f:A -> B) `{!forall x y, IsTruncMap n (@ap _ _ f x y)}
  : IsTruncMap n.+1 f.
Proof.
  intros y [a p] [b q];
    destruct q;
    exact (trunc_equiv' _ (hfiber_ap p)).
Defined.

Definition equiv_istruncmap_ap `{Funext} {A B} n (f:A -> B)
  : IsTruncMap n.+1 f <~> (forall x y, IsTruncMap n (@ap _ _ f x y))
  := equiv_iff_hprop (@istruncmap_ap _ _ n f) (@istruncmap_from_ap _ _ n f).

Global Instance isequiv_ap_isembedding {A B} (f : A -> B) `{!IsEmbedding f}
  : forall x y, IsEquiv (@ap _ _ f x y).
Proof.
  intros x y. apply isequiv_fcontr,_.
Defined.

Definition isembedding_isequiv_ap {A B} (f : A -> B) `{!forall x y, IsEquiv (@ap _ _ f x y)}
  : IsEmbedding f.
Proof.
  apply istruncmap_from_ap. intros x y;red;apply fcontr_isequiv,_.
Defined.

Definition equiv_isequiv_ap_isembedding `{Funext} {A B} (f : A -> B)
  : IsEmbedding f <~> (forall x y, IsEquiv (@ap _ _ f x y)).
Proof.
  exact (equiv_iff_hprop (@isequiv_ap_isembedding _ _ f) (@isembedding_isequiv_ap _ _ f)).
Defined.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal27.

Set Printing Depth 1000.
Definition lfind_eval  n x:=
append (append (rev x) (Cons n Nil)) Nil.

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Nil).


Require Export XR_Rmult_lt_reg_l.
Require Export XR_Rmult_comm.

Local Open Scope R_scope.

Lemma Rmult_lt_reg_r : forall r r1 r2,
  R0 < r ->
  r1 * r < r2 * r ->
  r1 < r2.
Proof.
  intros x y z hx hyz.
  apply Rmult_lt_reg_l with x.
  { exact hx. }
  {
    repeat rewrite (Rmult_comm x).
    exact hyz.
  }
Qed.


(** DISCLAIMER: this file is under construction and still contains a
    couple admits. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Multisets                                                               *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From TLC Require Import LibTactics LibLogic LibReflect
  LibRelation LibList LibInt LibNat LibOperation
  LibEpsilon LibSet LibMonoid.
From TLC Require Export LibContainer.

(* ********************************************************************** *)
(** * Construction of sets as predicates *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Definition multiset (A : Type) := A -> nat.

Section Operations.
Variables (A B : Type).
Implicit Types x : A.
Implicit Types E F G : multiset A.

Definition empty_impl : multiset A := fun _ => 0.

Definition single_impl x := fun y => If x = y then 1 else 0.

Definition in_impl x E := E x > 0.

Definition union_impl E F := fun x => (E x + F x)%nat.

Definition incl_impl E F := forall x, E x <= F x.

Definition dom_impl E := set_st (fun x => E x > 0).

(* -- TODO: update these definitions to match those of finite sets *)
Definition list_repr_impl (E:multiset A) (l:list (A*nat)) :=
     noduplicates (LibList.map (@fst _ _) l)
  /\ forall n x, mem (x,n) l <-> (n = E x /\ n > 0).

Definition to_list_impl (E:multiset A) := epsilon (list_repr_impl E).

Definition fold_impl (m:monoid_op B) (f:A->nat->B) (E:multiset A) :=
  LibList.fold_right (fun p acc => let (x,n) := p : A*nat in monoid_oper m (f x n) acc)
    (monoid_neutral m) (to_list_impl E).

End Operations.

Definition card_impl A (E:multiset A) :=
  fold_impl (monoid_make plus 0) (fun _ n => n) E.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Lemma in_inst : forall A, BagIn A (multiset A).
Proof using. constructor. exact (@in_impl A). Defined.

Hint Extern 1 (BagIn _ (multiset _)) => apply in_inst
  : typeclass_instances.

Instance empty_inst : forall A, BagEmpty (multiset A).
  constructor. rapply (@empty_impl A). Defined.

Instance single_inst : forall A, BagSingle A (multiset A) .
  constructor. rapply (@single_impl A). Defined.

Instance union_inst : forall A, BagUnion (multiset A).
  constructor. rapply (@union_impl A). Defined.

Instance incl_inst : forall A, BagIncl (multiset A).
  constructor. rapply (@incl_impl A). Defined.

Instance fold_inst : forall A B, BagFold B (A->nat->B) (multiset A).
  constructor. rapply (@fold_impl A B). Defined.

Instance card_inst : forall A, BagCard (multiset A).
  constructor. rapply (@card_impl A). Defined.

Global Opaque multiset empty_inst single_inst in_inst
 union_inst incl_inst fold_inst card_inst.

Instance Inhab_multiset : forall A, Inhab (multiset A).
Proof using. intros. apply (Inhab_of_val (@empty_impl A)). Qed.

(* ********************************************************************** *)
(** * Properties of multisets *)

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

Section Instances.
Variables (A:Type).
Hint Extern 1 False => math.
Hint Extern 1 (_ > _) => solve [ math | false ].
Hint Extern 1 (_ = _) => math.

Transparent multiset empty_inst single_inst in_inst
 union_inst incl_inst fold_inst card_inst.

Global Instance in_empty_eq_inst : In_empty_eq (A:=A) (T:=multiset A).
Proof using.
  constructor. intros. extens. simpl.
  unfold empty_impl, in_impl. autos*.
Qed.

Global Instance in_single_eq_inst : In_single_eq (A:=A) (T:=multiset A).
Proof using.
  constructor. intros. extens. simpl.
  unfold single_impl, in_impl. case_if*.
Qed.

Global Instance in_union_eq_inst : In_union_eq (A:=A) (T:=multiset A).
Proof using.
  constructor. intros. extens. simpl.
  unfold single_impl, union_impl, in_impl.
  iff. tests: (E x = 0). right~. left~. destruct H; math.
Qed.

Global Instance incl_inv_inst : Incl_inv (A:=A) (T:=multiset A).
Proof using.
  constructor. intros x. introv M N.
  unfold incl_inst, incl_impl,incl, in_inst, in_impl, is_in in *.
  specializes M x. math.
Qed.

Global Instance union_empty_inv_inst : Union_empty_inv (T:=multiset A).
Proof using.
  constructor. introv.
  unfold union_inst, union_impl, union, empty_impl,
   empty_inst, empty, empty_impl, multiset. introv N.
  split; extens~.
  intros x. lets: fun_eq_1 x N. math.
  intros x. lets: fun_eq_1 x N. math.
Qed.

Global Instance union_empty_l_eq_inst : Union_empty_l (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold union_impl, empty_impl, multiset. simpl. extens~.
Qed.

Global Instance union_comm_eq_inst : Union_comm (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold union_impl, multiset. simpl. extens~.
Qed.

Global Instance union_assoc_eq_inst : Union_assoc (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold union_impl, multiset. simpl. extens~.
Qed.

Global Instance empty_incl_inst : Empty_incl (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold empty_impl, multiset. math.
Qed.

Global Instance card_empty_inst : Card_empty (T:=multiset A).
Proof using. admit. (*-- TODO: under construction *) Qed.

Global Instance card_single_inst : Card_single (A:=A) (T:=multiset A).
Proof using. admit. (*-- TODO: under construction *) Qed.

Global Instance card_union_inst : Card_union (T:=multiset A).
Proof using. admit. (*-- TODO: under construction *) Qed.

End Instances.

(* ********************************************************************** *)
(** * Additional predicates *)

(* ---------------------------------------------------------------------- *)
(** ** Foreach *)

(** --TODO: foreach properties should be shared in LibContainer *)

Section ForeachProp.
Variables (A : Type).
Implicit Types P Q : A -> Prop.
Implicit Types E F : multiset A.

Lemma foreach_empty : forall P,
  @foreach A (multiset A) _ P \{}.
Proof using. intros_all. rewrite in_empty_eq in H. false. Qed.

Lemma foreach_single : forall P X,
  P X ->
  @foreach A (multiset A) _ P (\{ X }).
Proof using. intros_all. rewrite in_single_eq in H0. subst*. Qed.

Lemma foreach_union : forall P E F,
  foreach P E -> foreach P F -> foreach P (E \u F).
Proof using. intros_all. destruct~ (in_union_inv H1). Qed.

Hint Resolve foreach_empty foreach_single foreach_union.

Lemma foreach_union_inv : forall P E F,
  foreach P (E \u F) ->
  foreach P E /\ foreach P F.
Proof using.
  introv H. split; introv K.
  apply H. rewrite~ @in_union_eq. typeclass.
  apply H. rewrite~ @in_union_eq. typeclass.
Qed.

Lemma foreach_union_eq : forall P E F,
  foreach P (E \u F) = (foreach P E /\ foreach P F).
Proof using.
  intros. extens. iff.
  apply~ foreach_union_inv. apply* foreach_union.
Qed.

Lemma foreach_single_eq : forall P X,
  foreach P (\{X}:multiset A) = P X.
Proof using.
  intros. extens. iff.
  apply H. apply in_single_self.
  apply~ foreach_single.
Qed.

Lemma foreach_weaken : forall P Q E,
  foreach P E ->
  pred_incl P Q ->
  foreach Q E.
Proof using. introv H L K. apply~ L. Qed.

End ForeachProp.

(* ********************************************************************** *)
(** * Tactics *)

(** EXPERIMENTAL tactics -- TODO: add documentation *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove equalities on unions *)

Lemma for_multiset_union_assoc : forall A, assoc (union (T:=multiset A)).
Proof using. intros. apply union_assoc. Qed.

Lemma for_multiset_union_comm : forall A, comm (union (T:=multiset A)).
Proof using. intros. apply union_comm. Qed.

Lemma for_multiset_union_empty_l : forall A (E:multiset A), \{} \u E = E.
Proof using. intros. apply union_empty_l. Qed.

Lemma for_multiset_union_empty_r : forall A (E:multiset A), E \u \{} = E.
Proof using. intros. apply union_empty_r. Qed.

Lemma for_multiset_empty_incl : forall A (E:multiset A), \{} \c E.
Proof using. intros. apply empty_incl. Qed.

Hint Rewrite <- for_multiset_union_assoc : rew_permut_simpl.
Hint Rewrite for_multiset_union_empty_l for_multiset_union_empty_r : rew_permut_simpl.
Ltac rew_permut_simpl :=
  autorewrite with rew_permut_simpl.
Ltac rews_permut_simpl :=
  autorewrite with rew_permut_simpl in *.

Section PermutationTactic.
Context (A:Type).
Implicit Types l : multiset A.

Lemma permut_get_1 : forall l1 l2,
  (l1 \u l2) = (l1 \u l2).
Proof using. intros. auto. Qed.

Lemma permut_get_2 : forall l1 l2 l3,
  (l1 \u l2 \u l3) = (l2 \u l1 \u l3).
Proof using. intros. apply union_comm_assoc. Qed.
(* rewrite (union_comm _ l1). auto. Qed. *)

Lemma permut_get_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l4) = (l2 \u l3 \u l1 \u l4).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_2.
Qed.

Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l5)
  = (l2 \u l3 \u l4 \u l1 \u l5).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_3.
Qed.

Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6)
  = (l2 \u l3 \u l4 \u l5 \u l1 \u l6).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_4.
Qed.

Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l1 \u l7).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_5.
Qed.

Lemma permut_get_7 : forall l1 l2 l3 l4 l5 l6 l7 l8,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l1 \u l8).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_6.
Qed.

Lemma permut_get_8 : forall l1 l2 l3 l4 l5 l6 l7 l8 l9,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l9)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l1 \u l9).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_7.
Qed.

Lemma permut_tactic_setup : forall C l1 l2,
   C (\{} \u l1 \u \{}) (l2 \u \{}) -> C l1 l2.
Proof using. intros. rews_permut_simpl. eauto. Qed.

Lemma permut_tactic_keep : forall C l1 l2 l3 l4,
  C ((l1 \u l2) \u l3) l4 ->
  C (l1 \u (l2 \u l3)) l4.
Proof using. intros. rews_permut_simpl. eauto. Qed.

Lemma permut_tactic_trans : forall C l1 l2 l3,
  l3 = l2 -> C l1 l3 -> C l1 l2.
Proof using. intros. subst~. Qed.

End PermutationTactic.

(** [permut_lemma_get n] returns the lemma [permut_get_n]
    for the given value of [n] *)

Ltac permut_lemma_get n :=
  match number_to_nat n with
  | 1%nat => constr:(permut_get_1)
  | 2%nat => constr:(permut_get_2)
  | 3%nat => constr:(permut_get_3)
  | 4%nat => constr:(permut_get_4)
  | 5%nat => constr:(permut_get_5)
  | 6%nat => constr:(permut_get_6)
  | 7%nat => constr:(permut_get_7)
  | 8%nat => constr:(permut_get_8)
  end.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 \u l2 \u .. \u \{}],
    (some of the lists [li] are put in the form [x::\{}]). *)

Ltac permut_simpl_prepare :=
   rew_permut_simpl;
   apply permut_tactic_setup;
   repeat rewrite <- union_assoc.

(* --TODO : doc *)

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l \u _ => constr:(1)
  | _ \u l \u _ => constr:(2)
  | _ \u _ \u l \u _ => constr:(3)
  | _ \u _ \u _ \u l \u _ => constr:(4)
  | _ \u _ \u _ \u _ \u l \u _ => constr:(5)
  | _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(6)
  | _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(7)
  | _ \u _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(8)
  | _ => constr:(0) (* not found *)
  end.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing *)

Ltac permut_simpl_once_for permut_tactic_simpl :=
  let go l0 l' :=
    match l0 with
    | _ \u \{} => fail 1
    | _ \u (?l \u ?lr) =>
      match permut_index_of l l' with
      | 0 => apply permut_tactic_keep
      | ?n => let F := permut_lemma_get n in
             eapply permut_tactic_trans;
             [ eapply F; try typeclass
             | apply permut_tactic_simpl ]
      end
     end in
   match goal with
   | |- _ ?x ?y => go x y
   | |- _ _ ?x ?y => go x y
   | |- _ _ _ ?x ?y => go x y
   | |- _ _ _ _ ?x ?y => go x y
   end.

Ltac permut_conclude :=
  first [ apply refl_equal
        | apply for_multiset_empty_incl ].

Ltac permut_simpl_for permut_tactic_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once_for permut_tactic_simpl;
  rew_permut_simpl;
  try permut_conclude.

Lemma permut_tactic_simpl_eq : forall A (l1 l2 l3 l4:multiset A),
  (l1 \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = (l2 \u l4).
Proof using. intros. subst. apply permut_get_2. Qed.

Lemma permut_tactic_simpl_incl : forall A (l1 l2 l3 l4:multiset A),
  (l1 \u l3) \c l4 ->
  (l1 \u (l2 \u l3)) \c (l2 \u l4).
Admitted. (* --TODO URGENT: reason on this tedious inclusion... *)

Ltac get_premut_tactic_simpl tt :=
  match goal with
  | |- ?x = ?y => constr:(permut_tactic_simpl_eq)
  | |- ?x \c ?y => constr:(permut_tactic_simpl_incl)
  end.

Ltac permut_simpl_once :=
  let L := get_premut_tactic_simpl tt in permut_simpl_once_for L.

Ltac permut_simpl :=
  let L := get_premut_tactic_simpl tt in permut_simpl_for L.

Tactic Notation "multiset_eq" :=
  permut_simpl.

Section DemoSetUnion.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma demo_multiset_union_permut_simpl_1 :
  forall l1 l2 l3 : multiset A,
  (l1 \u l2 \u l3) = (l3 \u l2 \u l1).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
  permut_conclude.
Qed.

Lemma demo_multiset_union_permut_simpl_2 :
  forall
  (x:A) l1 l2 l3 l4,
  (l1 \u \{x} \u l3 \u l2) \c (l1 \u l2 \u l4 \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
  permut_conclude.
Qed.

Lemma demo_multiset_union_permut_simpl_3 : forall (x y:A) l1 l1' l2 l3 l4,
  l1 \c l4 \u l1' ->
  (l1 \u (\{x} \u l2) \u \{x} \u (\{y} \u l3)) \c
  (\{y} \u \{x} \u (l1' \u l2 \u l4) \u (\{x} \u l3)).
Proof using.
  intros. dup.
  (* details *)
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  try permut_simpl_once.
  rew_permut_simpl.
  equates 1. apply H.
  permut_simpl_prepare.
  permut_simpl_once.
  rew_permut_simpl.
  permut_conclude.
  (* short *)
  permut_simpl. applys_eq H 1. permut_simpl.
Qed.

End DemoSetUnion.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove membership *)

Section InUnionGet.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma in_union_get_1 : forall x l1 l2,
  x \in l1 -> x \in (l1 \u l2).
Proof using. intros. apply in_union_l. auto. Qed.

Lemma in_union_get_2 : forall x l1 l2 l3,
  x \in l2 -> x \in (l1 \u l2 \u l3).
Proof using. intros. apply in_union_r. apply~ in_union_get_1. Qed.

Lemma in_union_get_3 : forall x l1 l2 l3 l4,
  x \in l3 -> x \in (l1 \u l2 \u l3 \u l4).
Proof using. intros. apply in_union_r. apply~ in_union_get_2. Qed.

Lemma in_union_get_4 : forall x l1 l2 l3 l4 l5,
  x \in l4 -> x \in (l1 \u l2 \u l3 \u l4 \u l5).
Proof using. intros. apply in_union_r. apply~ in_union_get_3. Qed.

Lemma in_union_get_5 : forall x l1 l2 l3 l4 l5 l6,
  x \in l5 -> x \in (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using. intros. apply in_union_r. apply~ in_union_get_4. Qed.

End InUnionGet.

Arguments in_union_get_1 [A] [x] [l1] [l2].
Arguments in_union_get_2 [A] [x] [l1] [l2] [l3].
Arguments in_union_get_3 [A] [x] [l1] [l2] [l3].
Arguments in_union_get_4 [A] [x] [l1] [l2] [l3] [l4].
Arguments in_union_get_5 [A] [x] [l1] [l2] [l3] [l4] [l5].

(** [in_union_get] solves a goal of the form
    [x \in F1 \u ... \u FN] when there exists an
    hypothesis of the form [x \in Fi] for some [i]. *)

Ltac in_union_get :=
  match goal with H: ?x \in ?A |- ?x \in ?B =>
  match B with context [A] =>
  let go tt := first
        [ apply (in_union_get_1 H)
        | apply (in_union_get_2 H)
        | apply (in_union_get_3 H)
        | apply (in_union_get_4 H)
        | apply (in_union_get_5 H) ] in
  first [ go tt
        | rewrite <- (for_multiset_union_empty_r B);
          repeat rewrite <- for_multiset_union_assoc;
          go tt ]
  end end.

(* -- DEPRECATED Removed hint:
      Hint Extern 3 (_\in _ \u _) => in_union_get. *)

Section InUnionExtract.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma in_union_extract_1 : forall x l1,
  x \in (\{x} \u l1).
Proof using. intros. apply in_union_get_1. apply in_single_self. Qed.

Lemma in_union_extract_2 : forall x l1 l2,
  x \in (l1 \u \{x} \u l2).
Proof using. intros. apply in_union_get_2. apply in_single_self. Qed.

Lemma in_union_extract_3 : forall x l1 l2 l3,
  x \in (l1 \u l2 \u \{x} \u l3).
Proof using. intros. apply in_union_get_3. apply in_single_self. Qed.

Lemma in_union_extract_4 : forall x l1 l2 l3 l4,
  x \in (l1 \u l2 \u l3 \u \{x} \u l4).
Proof using. intros. apply in_union_get_4. apply in_single_self. Qed.

Lemma in_union_extract_5 : forall x l1 l2 l3 l4 l5,
  x \in (l1 \u l2 \u l3 \u l4 \u \{x} \u l5).
Proof using. intros. apply in_union_get_5. apply in_single_self. Qed.

End InUnionExtract.

(** [in_union_extract] solves a goal of the form
    [x \in F1 \u ... \u \{x} \u ... \u FN]. *)

Ltac in_union_extract :=
  match goal with |- ?x \in ?A =>
  match A with context [\{x}] =>
  let go tt := first
        [ apply (in_union_extract_1)
        | apply (in_union_extract_2)
        | apply (in_union_extract_3)
        | apply (in_union_extract_4)
        | apply (in_union_extract_5) ] in
  first [ go tt
        | rewrite <- (for_multiset_union_empty_r A);
          repeat rewrite <- for_multiset_union_assoc;
          go tt ]
  end end.

Tactic Notation "multiset_in" :=
   first [ in_union_extract | in_union_get ].

(* ---------------------------------------------------------------------- *)
(** ** Tactics to invert a membership hypothesis *)

Section InversionsTactic.
Context (A:Type).
Implicit Types l : multiset A.
Implicit Types x : A.

Lemma empty_eq_single_inv_1 : forall x l1 l2,
  l1 = l2 -> x \notin l1 -> x \in l2 -> False.
Proof using. intros. subst*. Qed.

Lemma empty_eq_single_inv_2 : forall x l1 l2,
  l1 = l2 -> x \notin l2 -> x \in l1 -> False.
Proof using. intros. subst*. Qed.

Lemma notin_empty : forall x,
  x \notin (\{}:multiset A).
Proof using. intros. unfold notin. rewrite in_empty_eq. auto. Qed.

End InversionsTactic.
Hint Resolve notin_empty.

Ltac in_union_meta :=
  match goal with
  | |- _ \in \{_} => apply in_single_self
  | |- _ \in \{_} \u _ => apply in_union_l; apply in_single_self
  | |- _ \in _ \u _ => apply in_union_r; in_union_meta
  end.

Ltac fseq_inv_core H :=
  let go L :=
     false L; [ apply H
              | try apply notin_empty
              | instantiate; try in_union_meta ] in
  match type of H with
  | \{} = _ => go empty_eq_single_inv_1
  | _ = \{} => go empty_eq_single_inv_2
  | _ = _ => go empty_eq_single_inv_1
  end.

(** [multiset_inv H] solves a goal by contraction if
    there exists an hypothesis of the form
    [\{} = E1 \u ... \u \{x} \u ... \u EN]
    (or its symmetric).
    [multiset_inv] speculates on the hypothesis [H] to
    be used. *)

Tactic Notation "multiset_inv" constr(H) :=
  fseq_inv_core H.

Tactic Notation "multiset_inv" :=
  match goal with
  | |- \{} <> _ => let H := fresh in intro H; multiset_inv H
  | |- _ <> \{} => let H := fresh in intro H; multiset_inv H
  | H: \{} = _ |- _ => multiset_inv H
  | H: _ = \{} |- _ => multiset_inv H
  end.

Section InUnionInv.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma in_empty_inv : forall x,
  x \in (\{}:multiset A) -> False.
Proof using. introv. apply notin_empty. Qed.

Lemma in_single_inv : forall x y : A,
  x \in (\{y}:multiset A) -> x = y.
Proof using. intros. rewrite @in_single_eq in H. auto. typeclass. Qed.

Lemma in_union_inv : forall x l1 l2,
  x \in (l1 \u l2) -> x \in l1 \/ x \in l2.
Proof using. introv H. rewrite @in_union_eq in H. auto. typeclass. Qed.

End InUnionInv.

Arguments in_single_inv [A] [x] [y].
Arguments in_union_inv [A] [x] [l1] [l2].

Ltac multiset_in_inv_base H M :=
  match type of H with
  | _ \in \{} => false; apply (@in_empty_inv _ _ H)
  | _ \in \{_} =>
    generalize (in_single_inv H); try clear H; try intro_subst_hyp
  | _ \in _ \u _ =>
    let H' := fresh "TEMP" in
    destruct (in_union_inv H) as [H'|H'];
    try clear H; multiset_in_inv_base H' M
  | _ => rename H into M
  end.

Tactic Notation "multiset_in" constr(H) "as" ident(M) :=
  multiset_in_inv_base H M.
Tactic Notation "multiset_in" constr(H) :=
  let M := fresh "H" in multiset_in H as M.

Lemma union_empty_inv_multiset : forall A (l1 l2:multiset A),
  l1 \u l2 = \{} -> l1 = \{} /\ l2 = \{}.
Proof using. intros. eapply union_empty_inv_inst. eauto. Qed.

Arguments union_empty_inv_multiset [A] [l1] [l2].

Ltac multiset_empty_core H :=
  match type of H with
  | _ \u _ = \{} =>
     let H1 := fresh "M" in let H2 := fresh "M" in
     destruct (union_empty_inv_multiset H) as [H1 H2]; clear H;
     multiset_empty_core H1; multiset_empty_core H2
  | ?E = \{} => try subst E; try solve [ false ]
  | \{} = _ \u _ => symmetry in H; multiset_empty_core H
  | \{} = ?E => symmetry in H; multiset_empty_core H
  end.

Tactic Notation "multiset_empty" "in" hyp(H) :=
  multiset_empty_core H.
Tactic Notation "multiset_empty" :=
  let H := fresh "M" in intro H; multiset_empty in H.
Tactic Notation "multiset_empty" constr(E) :=
  let H := fresh "M" in lets H:E; multiset_empty in H.


Require Export D.

(** **** Problem #15 : 1 star (sillyex1)
    Hint: Use the [inversion] tactic. *)
Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof.
  intros. inversion H0. reflexivity.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func_Prop.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import NatTrans.NatTrans NatTrans.Operations.
Require Import Adjunction.Adjunction Adjunction.Duality
        Adjunction.Adj_Facts.
Require Import KanExt.Global KanExt.Local KanExt.LocalFacts.ConesToHom
        KanExt.LocalFacts.HomToCones KanExt.GlobalDuality.

Local Open Scope functor_scope.

(** This module contains conversion from global to local kan extensions. *)
Section Global_to_Local_Right.
  Context {C C' : Category}
          (p : C –≻ C')
          (D : Category)
          (rke : Right_KanExt p D)
          (F : C –≻ D).

  (** The cone which (we will prove) is the local kan extension. *)
  Definition Cone_for_LoKan : LoKan_Cone p F :=
    {|
      cone_apex := (rke _o F)%object;
      cone_edge := @adj_morph_ex _ _ _ _ (right_kan_ext_adj rke) (rke _o F) F (NatTrans_id _)
    |}.

  Section Cone_Morph_to_Cone_for_LoKan.
    Context (Cn : LoKan_Cone p F).

    (** We show that any natural transformation from any cone (the apex functor of a cone)
to (apex functor of) the cone we constructed above remains the same under the following transformation:

  morph : Cn ——––>  (rke _o F)

  morph ∘_h (NatTrans_id p) : (Cn ∘ p) ————> ((rke _o F) ∘ p)

  η_{NatTrans_id (rke _o F)} ∘ (morph ∘_h (NatTrans_id p)) : (Cn ∘ p) ————> F

  rke @_a (Cn ∘ p) F (η_{NatTrans_id (rke _o F)} ∘ (morph ∘_h (NatTrans_id p))) :
     (rke _o (Cn ∘ p)) ————> (rke _o F)

  (rke @_a (Cn ∘ p) F (η_{NatTrans_id (rke _o F)} ∘ (morph ∘_h (NatTrans_id p))))
  ∘ (Trans (adj_unit (right_kan_ext_adj rke)) Cn) :
     Cn ————> (rke _o F)

  This result is used to show existence and unique ness of cones from Cn to the cone constructed above.

     *)

    Lemma Cone_Morph_to_Cone_for_LoKan_adj_unit_rke_id (morph : (Cn –≻ ((rke _o)%object F))%nattrans) :
      morph =
      (
        (
          (rke @_a)%morphism (Cn ∘ p)%functor F
                 (
                   (adj_morph_ex (right_kan_ext_adj rke) (NatTrans_id ((rke _o) F)%object))
                     ∘ (morph ∘_h (NatTrans_id p))
                 )
        ) ∘ (Trans (adj_unit (right_kan_ext_adj rke)) Cn)
      )%nattrans.
    Proof.
      rewrite (@F_compose); cbn.
      rewrite NatTrans_compose_assoc.
      cbn_rewrite <- (@Trans_com _ _ _ _ (@adj_unit _ _ _ _ (right_kan_ext_adj rke)) _ _ morph).
      rewrite <- NatTrans_compose_assoc.
      cbn_rewrite <- (
                    @adj_morph_com _ _ _ _
                                   (right_kan_ext_adj rke)
                                   _
                                   _
                                   (NatTrans_id ((rke _o)%object F))
                  ).
      rewrite NatTrans_id_unit_left.
      trivial.
    Qed.

    (** Given a cone, we construct a cone morph to the cone morph that we constructed above. *)
    Program Definition Cone_Morph_to_Cone_for_LoKan : LoKan_Cone_Morph Cn Cone_for_LoKan :=
      {|
        cone_morph := ((rke _a (cone_edge Cn))%morphism ∘ (Trans (adj_unit (right_kan_ext_adj rke)) Cn))%nattrans
      |}.

    Next Obligation.
    Proof.
      match goal with
        [|- _ = NatTrans_compose (NatTrans_hor_comp _ ?X) _] =>
        apply (@adj_morph_unique _ _ _ _ (right_kan_ext_adj rke) _ _ X); trivial
      end.
      apply Cone_Morph_to_Cone_for_LoKan_adj_unit_rke_id.
    Qed.

  End Cone_Morph_to_Cone_for_LoKan.

  Section Cone_Morph_to_Cone_for_LoKan_Unique.
    Context {Cn : LoKan_Cone p F} (M M' : LoKan_Cone_Morph Cn Cone_for_LoKan).

    (** Cone morph to the cone constructed is unique. *)
    Theorem Cone_Morph_to_Cone_for_LoKan_Unique : (M = M' :> (_ –≻ _)%nattrans).
    Proof.
      rewrite (Cone_Morph_to_Cone_for_LoKan_adj_unit_rke_id Cn M).
      rewrite (Cone_Morph_to_Cone_for_LoKan_adj_unit_rke_id Cn M').
      do 2 apply f_equal.
      set (H := cone_morph_com M'); rewrite (cone_morph_com M) in H; exact H.
    Qed.

  End Cone_Morph_to_Cone_for_LoKan_Unique.

  (** The conversion from global kan extensions to local kan extensions *)
  Definition Global_to_Local_Right : Local_Right_KanExt p F :=
    {|
      LRKE := Cone_for_LoKan;
      LRKE_morph_ex := Cone_Morph_to_Cone_for_LoKan;
      LRKE_morph_unique := @Cone_Morph_to_Cone_for_LoKan_Unique
    |}.

End Global_to_Local_Right.

(** Teh conversion from global left kan extensions to local left kan extensions is jsut
the dual what we just proved. *)
Section Global_to_Local_Left.
  Context {C C' : Category}
          (p : C –≻ C')
          (D : Category)
          (lke : Left_KanExt p D)
          (F : C –≻ D).

  Definition Global_to_Local_Left : Local_Left_KanExt p F :=
    Global_to_Local_Right _ _ (KanExt_Left_to_Right _ _ lke) (F^op).

End Global_to_Local_Left.


Inductive syntax {var : Type} :=
| Var (v : var)
| Zero (* 0 *)
| One  (* 1 *)
| Tensor (Left : syntax) (Right : syntax) (* ⊗ *)
| With   (Left : syntax) (Right : syntax) (* & *)
| Implication (Left : syntax) (Right : syntax) (* ⊸ *)
| Bang (Right : syntax) (* ! *)
.