(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2014-12-11

* Finite sets and their cardinal

Standard definition of set finiteness (existence of a bijection to
some prefix of nat) and definition of the cardinal of a finite set
(using Church's iota). *)

Set Implicit Arguments.

From Coq Require Import Basics Morphisms Setoid.
From CoLoR Require Import ClassicUtil IotaUtil EpsilonUtil LogicUtil NatUtil
     FunUtil ListUtil ListNodup SetUtil BoundNat.

Section S.

  Variable A : Type.

  Notation set := (set A).

(****************************************************************************)
(** * Definition of finiteness *)

  Definition finite (P : set) := exists n (f : N n -> elts P), bijective f.

(****************************************************************************)
(** * Properties of [finite] *)

(** Finiteness is invariant by set equivalence. *)

  Global Instance finite_equiv : Proper (equiv ==> impl) finite.

  Proof.
    intros P Q PQ [n [f [f_inj f_surj]]].
    set (g := fun k : N n => elts_equiv PQ (f k)).
    ex n g. split.
    (* g is injective. *)
    intros x y e. apply f_inj. apply sig_eq in e. revert e. unfold g.
    case_eq (f x); intros a_val a ef. case_eq (f y); intros b_val b eg.
    simpl. intro e. apply sig_eq. auto.
    (* g is surjective. *)
    intro y. assert (QP : Q [=] P). hyp.
    destruct (f_surj (elts_equiv QP y)) as [x hx].
    ex x. unfold g. rewrite <- hx. apply sig_eq. destruct y as [y_val y].
    refl.
  Qed.

(** Finiteness of sets defined by a list of elements. *)

  Lemma finite_of_list_nodup l : nodup l -> finite (of_list l).

  Proof.
    destruct l.
    (* l = nil *)
    intros _. exists 0. exists any_of_N0. split.
    intros [x_val x]. intros; lia.
    intros [y_val y]. contradiction.
    (* l <> nil *)
    rename l into l'. set (l := a :: l').
    intro hl. set (n := length l). ex n.
    assert (i : forall k : N n, k < n). intros [k_val k]. simpl. lia.
    set (f := fun k : N n => elt (P:=of_list l) (nth_In a (i k))). ex f.
    split.
    (* f injective *)
    intros [x_val x] [y_val y]. unfold f; simpl. intro e. apply N_eq; simpl.
    apply sig_eq in e; simpl in e. subst n. eapply inj_nth_nodup.
    2: apply hl. apply eq_dec. hyp. hyp. apply e.
    (* f surjective *)
    intros [y_val y]. gen (In_nth a y); intros [k [k1 k2]].
    ex (N_ k1). apply sig_eq; simpl. auto.
  Qed.

  Lemma finite_of_list l : finite (of_list l).

  Proof.
    assert (e : of_list l [=] of_list (remdup eq_dec l)).
    intro x. unfold mem, of_list. sym. apply In_remdup.
    rewrite e. apply finite_of_list_nodup. apply nodup_remdup.
  Qed.

(** A set [P] is finite if there is a surjection from [N n] to [P]. *)

  Lemma finite_surj P n (f : N n -> elts P) : surjective f -> finite P.

  Proof.
    intro f_surj. rewrite (of_map_L f_surj). apply finite_of_list.
  Qed.

(** A set [P] is finite iff it can be defined by a list of elements. *)

  Lemma finite_eq P : finite P <-> exists l, P [=] of_list l.

  Proof.
    split.
    (* -> *)
    intros [n [f [f_inj f_surj]]].
    ex (map (elt_val o f) (L n)). apply of_map_L. hyp.
    (* <- *)
    intros [l e]. rewrite e. apply finite_of_list.
  Qed.

(** Finiteness is contravariant wrt inclusion. *)

  Global Instance finite_subset : Proper (subset --> impl) finite.

  Proof.
    intros P Q QP. rewrite !finite_eq. intros [l e]. ex (select (dec1 Q) l).
    gen (select_correct (dec1 Q) l). gen (select_complete (dec1 Q) l). fo.
  Qed.

(** A set [P] is finite iff it can be defined by a non-duplicating
list of elements. *)

  Lemma finite_eq_nodup P : finite P <-> exists l, P [=] of_list l /\ nodup l.

  Proof.
    split. rewrite finite_eq. intros [l e]. ex (remdup eq_dec l). split.
    rewrite e. intro x. sym. apply In_remdup. apply nodup_remdup.
    intros [l [e _]]. rewrite e. apply finite_of_list.
  Qed.

(****************************************************************************)
(** * List of the elements of a finite set. *)

  Definition list_of_finite P : finite P -> list A.

  Proof.
    (*COQ: rewrite finite_eq_nodup.(*makes Stack overflow!*)*)
    intro P_fin. rewrite finite_eq_nodup in P_fin. apply cid in P_fin.
    destruct P_fin as [l _]. exact l.
  Defined.

  Lemma finite_eq_of_list P (P_fin : finite P) :
    P [=] of_list (list_of_finite P_fin).

  Proof.
    unfold list_of_finite.
    destruct (cid (iff_impl_subrelation (finite P)
               (exists l : list A, P [=] of_list l /\ nodup l)
               (finite_eq_nodup P) P_fin)). tauto.
  Qed.

  Lemma nodup_list_of_finite P (P_fin : finite P) :
    nodup (list_of_finite P_fin).

  Proof.
    unfold list_of_finite.
    destruct (cid (iff_impl_subrelation (finite P)
               (exists l : list A, P [=] of_list l /\ nodup l)
               (finite_eq_nodup P) P_fin)). tauto.
  Qed.

  Lemma In_list_of_finite x P (P_fin : finite P) :
    In x (list_of_finite P_fin) <-> P x.

  Proof.
    unfold list_of_finite.
    destruct (cid (iff_impl_subrelation (finite P)
               (exists l : list A, P [=] of_list l /\ nodup l)
               (finite_eq_nodup P) P_fin)). fo.
  Qed.

(****************************************************************************)
(** Finiteness of [empty]. *)

  Lemma empty_of_list : empty [=] of_list (@nil A).

  Proof. fo. Qed.

  Lemma finite_empty : finite empty.

  Proof. rewrite empty_of_list. apply finite_of_list. Qed.

(****************************************************************************)
(** [add] preserves finiteness. *)

  Lemma finite_add a P : finite P -> finite (add a P).

  Proof.
    destruct (classic (mem a P)).
    (*COQ: rewrite add_already_in does not work here*)
    intro P_fin. rewrite add_already_in; hyp.
    rewrite finite_eq; intros [l e].
    rewrite e, <- of_cons. apply finite_of_list.
  Qed.

  Lemma finite_add_eq a P : finite (add a P) <-> finite P.

  Proof.
    split. 2: apply finite_add. destruct (classic (mem a P)).
    rewrite add_already_in; auto.
    rewrite finite_eq; intros [l e].
    rewrite <- (rem_add H), e , <- (of_remove eq_dec). apply finite_of_list.
  Qed.

(****************************************************************************)
(** Finiteness of a [singleton]. *)

  Lemma finite_singleton a : finite (singleton a).

  Proof. unfold singleton. apply finite_add. apply finite_empty. Defined.

(****************************************************************************)
(** [rem] preserves finiteness. *)

  Lemma finite_rem a P : finite P -> finite (rem a P).

  Proof.
    destruct (classic (mem a P)).
    rewrite finite_eq; intros [l e].
    rewrite e, <- (of_remove eq_dec). apply finite_of_list.
    intro P_fin. rewrite rem_notin; hyp.
  Qed.

  Lemma finite_rem_eq a P : finite (rem a P) <-> finite P.

  Proof.
    split. 2: apply finite_rem. destruct (classic (mem a P)).
    rewrite finite_eq; intros [l e].
    rewrite <- (add_rem eq_dec H), e, <- of_cons. apply finite_of_list.
    rewrite rem_notin; auto.
  Qed.

(****************************************************************************)
(** [union] preserves finiteness. *)

  Lemma finite_union P Q : finite P -> finite Q -> finite (union P Q).

  Proof.
    rewrite 2!finite_eq. intros [p hp] [q hq]. rewrite hp, hq, <- of_app.
    apply finite_of_list.
  Qed.

  Lemma finite_union_eq P Q : finite (union P Q) <-> finite P /\ finite Q.

  Proof.
    split. 2: intros [P_fin Q_fin]; apply finite_union; hyp.
    revert P Q. cut (forall P Q, finite (union P Q) -> finite P).
    intros L P Q PUQ_fin. split; eapply L. apply PUQ_fin.
    rewrite union_com. apply PUQ_fin.
    intros P Q. rewrite !finite_eq. intros [l hl]. ex (select (dec1 P) l).
    intro x. split.
    intro xP. hnf. apply select_complete; fo.
    intro xPl. hnf in xPl. apply select_correct in xPl. fo.
  Qed.

(****************************************************************************)
(** [diff] preserves finiteness. *)

  Lemma finite_diff P : finite P -> forall Q, finite (diff P Q).

  Proof.
    rewrite finite_eq. intros [l Pl]. intro Q. rewrite finite_eq.
    ex (select (fun x => dec (~mem x Q)) l). split; intro hx.
    apply select_complete; fo.
    unfold mem, of_list in hx. apply select_correct in hx. fo.
  Qed.

(****************************************************************************)
(** * Type of finite sets. *)

  Definition Pf := sig finite.

  Definition mk_Pf P (P_fin : finite P) : Pf := exist P_fin.

  Coercion mk_Pf : finite >-> Pf.

  Definition Pf_val (P : Pf) : set := proj1_sig P.

  Coercion Pf_val : Pf >-> SetUtil.set.

  Definition Pf_prf (P : Pf) : finite (Pf_val P) := proj2_sig P.

  Coercion Pf_prf : Pf >-> finite.

(****************************************************************************)
(** Inclusion and equivalence of finite sets. *)

  Definition Pf_subset (P Q : Pf) := P [<=] Q.

  Global Instance Pf_subset_preorder : PreOrder Pf_subset.

  Proof. fo. Qed.

  Definition Pf_equiv (P Q : Pf) := P [=] Q.

  Infix "=f=" := Pf_equiv (at level 70).

  Global Instance Pf_equiv_Equivalence : Equivalence Pf_equiv.

  Proof. fo. Qed.

  Global Instance Pf_val_subset : Proper (Pf_subset ==> subset) Pf_val.

  Proof. fo. Qed.

  Global Instance Pf_val_equiv : Proper (Pf_equiv ==> equiv) Pf_val.

  Proof. fo. Qed.

  Lemma Pf_equiv_of {P Q : Pf} : P [=] Q -> P =f= Q.

  Proof. unfold Pf_equiv. auto. Qed.

  (*FIXME?Coq warning:
  witness does not respect the uniform inheritance condition*)
  Coercion Pf_equiv_of : equiv >-> Pf_equiv.

  Lemma Pf_equiv_of_gen (P Q : Pf) P_val Q_val :
    P [=] P_val -> Q [=] Q_val -> P_val [=] Q_val -> P =f= Q.

  Proof. intros e1 e2. unfold Pf_equiv. rewrite e1, e2. auto. Qed.

  Definition Pf_equiv_of2 {P Q : Pf} :=
    Pf_equiv_of_gen P Q (reflexivity _) (reflexivity _).

(****************************************************************************)
(** Constructors of finite sets. *)

  Definition Pf_of_list l : Pf := finite_of_list l.

  Definition Pf_empty : Pf := finite_empty.

  Definition Pf_add x (P : Pf) : Pf := finite_add x P.

  Global Instance Pf_add_subset :
    Proper (eq ==> Pf_subset ==> Pf_subset) Pf_add.

  Proof. intros x y xy P Q. unfold Pf_subset; simpl. apply add_subset. hyp. Qed.

  Global Instance Pf_add_equiv : Proper (eq ==> Pf_equiv ==> Pf_equiv) Pf_add.

  Proof. intros x y xy P Q. unfold Pf_equiv; simpl. apply add_equiv. hyp. Qed.

  Definition Pf_singleton x : Pf := finite_singleton x.

  Lemma Pf_singleton_eq x : Pf_singleton x =f= Pf_add x Pf_empty.

  Proof. refl. Qed.

  Definition Pf_rem x (P : Pf) : Pf := finite_rem x P.

  Global Instance Pf_rem_subset :
    Proper (eq ==> Pf_subset ==> Pf_subset) Pf_rem.

  Proof. intros x y xy P Q. unfold Pf_subset; simpl. apply rem_subset. hyp. Qed.

  Global Instance Pf_rem_equiv : Proper (eq ==> Pf_equiv ==> Pf_equiv) Pf_rem.

  Proof. intros x y xy P Q. unfold Pf_equiv; simpl. apply rem_equiv. hyp. Qed.

  Definition Pf_union (P Q : Pf) : Pf := finite_union P Q.

  Global Instance Pf_union_subset :
    Proper (Pf_subset ==> Pf_subset ==> Pf_subset) Pf_union.

  Proof.
    intros P Q PQ R S RS. unfold Pf_subset in *; simpl in *.
    apply union_subset; hyp.
  Qed.

  Global Instance Pf_union_equiv :
    Proper (Pf_equiv ==> Pf_equiv ==> Pf_equiv) Pf_union.

  Proof.
    intros P Q PQ R S RS. unfold Pf_equiv in *; simpl in *.
    apply union_equiv; hyp.
  Qed.

  Definition Pf_diff (P Q : Pf) : Pf := finite_diff P Q.

  Global Instance Pf_diff_subset :
    Proper (Pf_subset ==> Pf_subset --> Pf_subset) Pf_diff.

  Proof.
    intros P Q PQ R S SR. unfold flip, Pf_subset in *; simpl in *.
    apply diff_subset; hyp.
  Qed.

  Global Instance Pf_diff_equiv :
    Proper (Pf_equiv ==> Pf_equiv ==> Pf_equiv) Pf_diff.

  Proof.
    intros P Q PQ R S RS. unfold Pf_equiv in *; simpl in *.
    apply diff_equiv; hyp.
  Qed.

  Lemma Pf_equiv_of_list (P : Pf) : P =f= Pf_of_list (list_of_finite P).

  Proof. apply finite_eq_of_list. Qed.

  Lemma Pf_add_of_list a (l : list A) :
    Pf_add a (Pf_of_list l) =f= Pf_of_list (a :: l).

  Proof. unfold Pf_equiv; simpl. rewrite <- of_cons. refl. Qed.

(****************************************************************************)
(** Induction principle on finite sets. *)

  Lemma Pf_ind (P : Pf -> Prop) (P_equiv : Proper (Pf_equiv ==> impl) P)
    (P0 : P Pf_empty)
    (PS : forall a (X : Pf), ~mem a X -> P X -> P (Pf_add a X)) :
    forall X, P X.

  Proof.
    intro X. rewrite Pf_equiv_of_list. gen (nodup_list_of_finite X).
    gen (list_of_finite X). induction l; intro lnd.
    eapply P_equiv. 2: apply P0. fo.
    rewrite <- Pf_add_of_list. fo.
  Qed.

(****************************************************************************)
(** * Cardinal of a finite set *)

  Lemma card_uniq P :
    finite P -> exists! n, exists (f : N n -> elts P), bijective f.

  Proof.
    intros [n [f [f_inj f_surj]]]. ex n. split. ex f. fo.
    intros m [g [g_inj g_surj]]. apply le_antisym.
    apply N_inj_le with (f := inverse g_surj o f). inj.
    apply N_inj_le with (f := inverse f_surj o g). inj.
  Qed.

  Definition card : Pf -> nat.

  Proof.
    intros [P P_fin]. destruct (cdd (card_uniq P_fin)) as [n _]. exact n.
  Defined.

  Global Instance card_subset : Proper (Pf_subset ==> le) card.

  Proof.
    intros [P P_fin] [Q Q_fin] PQ. unfold card.
    destruct (cdd (card_uniq P_fin)) as [p [f [f_inj f_surj]]].
    destruct (cdd (card_uniq Q_fin)) as [q [g [g_inj g_surj]]].
    apply N_inj_le with (f := inverse g_surj o elts_subset PQ o f). inj.
    apply inj_elts_subset.
  Qed.

  Global Instance card_equiv : Proper (Pf_equiv ==> eq) card.

  Proof.
    intros [P P_fin] [Q Q_fin] PQ. unfold Pf_equiv in PQ.
    rewrite equiv_subset2 in PQ. destruct PQ as [PQ QP].
    gen (card_subset PQ). gen (card_subset QP). lia.
  Qed.

(****************************************************************************)
(** Induction on finite sets through their cardinals. *)

  Lemma card_ind (P : Pf -> Prop) (H : forall n X, card X = n -> P X) :
    forall X, P X.

  Proof. intro X. eapply H. refl. Qed.

(****************************************************************************)
(** * Cardinal of some finite set constructors. *)

(** Cardinal of a set defined by a list of elements. *)

  Lemma card_of_list_le_length_gen l (h : finite (of_list l)) :
    card h <= length l.

  Proof.
    unfold card.
    case_eq (mk_Pf h); intros P P_fin e; apply sig_eq in e; simpl in e; subst.
    destruct (cdd (card_uniq P_fin)) as [n [f [f_inj f_surj]]].
    destruct n. lia.
    set (g := fun i : N (S n) =>
                let (_, xl) := f i in N_ (pos_lt_length eq_dec xl)).
    apply N_inj_le with (f := g). intros i j. unfold g.
    case_eq (f i); intros x xl hx. case_eq (f j); intros y yl hy e.
    apply N_eq in e; simpl in e. apply inj_pos in e. 2: fo.
    subst y. apply f_inj. rewrite hx, hy. apply sig_eq. refl.
  Qed.

  Lemma card_of_list_le_length l : card (Pf_of_list l) <= length l.

  Proof. apply card_of_list_le_length_gen. Qed.

(** Cardinal of the empty set. *)

  Lemma card_empty_gen (h : finite empty) : card h = 0.

  Proof.
    cut (card h <= 0). lia. change (card h <= length (@nil A)).
    assert (e : Pf_equiv h (finite_of_list nil)). fo. rewrite e.
    apply card_of_list_le_length.
  Qed.

  Lemma card_empty : card Pf_empty = 0.

  Proof. apply card_empty_gen. Qed.

(** A set of null cardinality is empty. *)

  Lemma card_0 {P} : card P = 0 -> P =f= Pf_empty.

  Proof.
    unfold card. destruct P as [P P_fin].
    destruct (cdd (card_uniq P_fin)) as [n [f [f_inj f_surj]]]. intro; subst.
    unfold Pf_equiv; simpl. intro x. split. 2: fo.
    intro hx. destruct (f_surj (elt hx)) as [k _]. destruct k. lia.
  Qed.

(** Cardinal of a set defined by a non-duplcating list of elements. *)

  Lemma card_of_list_eq_length_gen l (h : finite (of_list l)) :
    nodup l -> card h = length l.

  Proof.
    intro l_nodup. destruct (dec (l = nil)) as [hl|hl].
    subst. rewrite card_empty_gen. refl.
    assert (a : A). destruct l. cong. exact a.
    apply le_antisym. apply card_of_list_le_length_gen.
    unfold card. case_eq (mk_Pf h); intros P P_fin e.
    apply sig_eq in e; simpl in e; subst.
    destruct (cdd (card_uniq P_fin)) as [n [f [f_inj f_surj]]].
    apply N_inj_le with (f := fun x : N (length l) =>
      inverse f_surj (elt (P:=of_list l) (nth_In a x))).
    intros [x_val x] [y_val y] e. apply N_eq; simpl.
    apply inj_inverse in e. apply sig_eq in e; simpl in e.
    apply inj_nth_nodup in e; auto. apply eq_dec.
  Qed.

  Lemma card_of_list_eq_length l : nodup l -> card (Pf_of_list l) = length l.

  Proof. apply card_of_list_eq_length_gen. Qed.

  Lemma Pf_eq_of_list (P : Pf) : P =f= Pf_of_list (list_of_finite P).

  Proof. apply finite_eq_of_list. Qed.

  Lemma card_eq P : card P = length (list_of_finite P).

  Proof.
    rewrite Pf_eq_of_list at 1. rewrite card_of_list_eq_length. refl.
    apply nodup_list_of_finite.
  Qed.

(** Cardinal of [add]. *)

  Lemma card_add a P :
    card (Pf_add a P) = card P + if dec (mem a P) then 0 else 1.

  Proof.
    destruct (dec (mem a P)).
    (* a in P *)
    rewrite <- plus_n_O. apply card_equiv. apply Pf_equiv_of; simpl.
    apply add_already_in. hyp.
    (* a not in P *)
    rewrite (Pf_eq_of_list P).
    set (l := list_of_finite P). set (P' := Pf_of_list l).
    rewrite (Pf_equiv_of2 (P:=Pf_add a P') (Q:=Pf_of_list (a::l))).
    rewrite card_of_list_eq_length. simpl length.
    unfold P', l. rewrite <- Pf_eq_of_list, <- card_eq. lia.
    simpl. split. unfold l. rewrite In_list_of_finite. hyp.
    apply nodup_list_of_finite.
    simpl. sym. apply of_cons.
  Qed.

(** Cardinal of [singleton]. *)

  Lemma card_singleton a : card (Pf_singleton a) = 1.

  Proof.
    rewrite Pf_singleton_eq, card_add, card_empty.
    destruct (dec (mem a Pf_empty)). firstorder with arith. refl.
  Qed.

(** Cardinal of [rem]. *)

  Lemma card_rem a P :
    card (Pf_rem a P) = card P - if dec (mem a P) then 1 else 0.

  Proof.
    destruct (dec (mem a P)).
    (* a in P *)
    rewrite (Pf_eq_of_list P).
    set (l := list_of_finite P). set (P' := Pf_of_list l).
    rewrite (Pf_equiv_of2 (P:=Pf_rem a P') (Q:=Pf_of_list (remove eq_dec a l))).
    assert (h : nodup l). apply nodup_list_of_finite.
    unfold P'. rewrite !card_of_list_eq_length, length_remove_nodup; auto.
    unfold l. rewrite In_list_of_finite. hyp. apply nodup_remove. hyp.
    simpl. sym. apply of_remove.
    (* a not in P *)
    rewrite <- minus_n_O. apply card_equiv. unfold Pf_equiv. simpl.
    apply rem_notin. hyp.
  Qed.

(** A set of non-null cardinality has at least one element. *)

  Lemma card_S {P n} : card P = S n ->
    exists a Q, P =f= Pf_add a Q /\ ~mem a Q /\ card Q = n.

  Proof.
    intro e. gen e. unfold card at 1. destruct P as [P P_fin]; simpl.
    destruct (cdd (card_uniq P_fin)) as [p [f f_bij]]; simpl. intro; subst.
    destruct (f zero) as [a aP]. ex a (Pf_rem a P_fin).
    split. unfold Pf_equiv; simpl. rewrite (add_rem eq_dec). refl. hyp.
    split. apply notin_rem.
    rewrite card_rem. unfold mk_Pf at 1. rewrite e.
    destruct (dec (mem a P_fin)). lia. contr.
  Qed.

(****************************************************************************)
(** * Type of subsets of some cardinality. *)

  Section Pcard.

    Variables (P : set) (n : nat).

    Definition Pcard := { Q : Pf | Q [<=] P /\ card Q = n }.

    Definition mk_Pcard (Q : Pf) : Q [<=] P -> card Q = n -> Pcard.

    Proof. intros QP h. ex Q. auto. Defined.

    Definition Pcard_val (Q : Pcard) : Pf := proj1_sig Q.

    Global Coercion Pcard_val : Pcard >-> Pf.

    Definition Pcard_equiv (Q R : Pcard) := Q =f= R.

    Global Instance Pcard_equiv_Equivalence : Equivalence Pcard_equiv.

    Proof. fo. Qed.

  End Pcard.

  Arguments mk_Pcard [P n Q] _ _.
  Arguments Pcard_equiv {P n} _ _.

  Infix "=c=" := Pcard_equiv (at level 70).

  Definition Pcard_subset n P P' : P [<=] P' -> Pcard P n -> Pcard P' n.

  Proof. intros PP' [Q [Q1 Q2]]. ex Q. split. trans P; hyp. hyp. Defined.

  Lemma Pcard_subset_inj n R P (PR : P [<=] R) Q (QR : Q [<=] R) :
    forall (x : Pcard P n) (y : Pcard Q n),
      x [=] y -> Pcard_subset PR x =c= Pcard_subset QR y.

  Proof. intros [X [XP Xn]] [Y [YQ Yn]] e. hyp. Qed.

  Lemma Pcard_subset_equiv P Q (PQ : P [<=] Q) n R :
    forall x : Pcard P n, x [=] R -> Pcard_subset PQ x [=] R.

  Proof. intros [X [XP Xn]] xR. hyp. Qed.

End S.

Arguments Pcard_equiv {A P n} _ _.
Arguments mk_Pcard [A P n Q] _ _.


(* Our main CPA example. *)

Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Ipdl.Big Pars Lib.Set Ipdl.Approx.

Module Type CPA.

  (* Our example is parameterized on lengths for the message, ciphertexts, and keys. (For our IPDL assumption to be realizable by IND-CPA, all messges in the type 'msg' must have the same length. ) *)
  Parameter (msg ctxt key : nat).
  Parameter (q : nat).

  Parameter (genK : Dist key.-bv).
  Parameter (enc : msg.-bv -> key.-bv -> Dist ctxt.-bv).
  Parameter (dec : ctxt.-bv -> key.-bv -> msg.-bv).

  (* In CPA0, we generate a secret key k randomly, and for j = 0..q,
    we read the j'th input message, and return the encryption of that
    message under k.  By the semantics of IPDL, the j'th output, o ## j,
     is available whenever the i'th input, i ## j, is
    available. Thus the below game enables all adversary queries to be
    made adversarially. *)

Definition CPA0 {chan:  Type -> Type} (i : q.-tuple (chan msg.-bv)) (o : q.-tuple (chan ctxt.-bv)) :=
  k <- new key.-bv ;;
  pars [::
          k ::= (Samp genK);
          \||_(j < q) (o ## j) ::=  (
                      m <-- Read (i ## j) ;; K <-- Read k ;;
                      c <-- Samp (enc m K) ;;
                      Ret c)].

(* CPA1 is the same as CPA0, but we encrypt a dummy message of all zeores *)
Definition CPA1 {chan : Type -> Type} (i : q.-tuple (chan msg.-bv)) (o : q.-tuple (chan ctxt.-bv)) :=
  k <- new key.-bv ;;
  pars [::
          k ::= (Samp genK);
          \||_(j < q) (o ## j) ::= (
                      _ <-- Read (i ##  j) ;; K <-- Read k ;;
                      c <-- Samp (enc [tuple of nseq msg false]  K) ;;
                      Ret c)].

  (* Security parameter for CPA security. For security, it must be that the length of keys and number of queries q is polynomial in lambda. *)
Parameter (lambda : nat).
Parameter (CPA_security :
              forall {chan : Type -> Type} (i : q.-tuple (chan msg.-bv)) o, CPA0 i o =a_(lambda, err1) CPA1 i o).

(* The following exact equivalence on protocols states correctness of decryption. It states that
the tuple (k, c, o) where k is a random key, c is an encryption of some message on an input channel i,
and o is the decryption of c, is equivalent to the tuple (k, c, i). *)

Definition dec_correct_def  := forall (chan : Type -> Type) (k : chan key.-bv) (c : chan ctxt.-bv) (i : chan msg.-bv) (o : chan msg.-bv),
    pars [::
            k ::= (Samp genK);
            c ::= (x <-- Read k ;; m <-- Read i ;; c <-- Samp (enc m x) ;; Ret c);
            o ::= (x <-- Read c ;; y <-- Read k ;; Ret (dec x y)) ] =p
    pars [::
            k ::= (Samp genK);
            c ::= (x <-- Read k ;; m <-- Read i ;; c <-- Samp (enc m x) ;; Ret c);
            o ::= (copy i) ].

Parameter (dec_correct : dec_correct_def).
(* Decryption correctness for a single message implies decryption correctness for q messages. *)
Lemma Multi_dec_correct {chan : Type -> Type} : forall (k : chan key.-bv) (c : q.-tuple (chan ctxt.-bv)) (i : q.-tuple (chan msg.-bv)) (o : q.-tuple (chan msg.-bv)),
    pars [::
            k ::= (Samp genK);
            \||_(j < q) (c ## j)  ::= (x <-- Read k ;; m <-- Read (tnth i j) ;; c <-- Samp (enc m x) ;; Ret c);
            \||_(j < q) (o ## j) ::= (x <-- Read (tnth c j) ;; y <-- Read k ;; Ret (dec x y)) ] =p
    pars [::
            Out k (Samp genK);
            \||_(j < q) (c ## j) ::= (x <-- Read k ;; m <-- Read (tnth i j) ;; c <-- Samp (enc m x) ;; Ret c);
            \||_(j < q) (o ## j) ::= (copy (tnth i j)) ].
  intros.
  swap_tac 0 2.
  rewrite -par_in_pars.
  rewrite -bigpar_par.
  symmetry.
  swap_tac 0 2.
  rewrite -par_in_pars.
  rewrite -bigpar_par.
  symmetry.
  apply pars_big_hybrid2; intros.
  rewrite bigpar_par par_in_pars.
  swap_tac 0 2; rewrite par_in_pars.
  symmetry.
  rewrite par_in_pars.
  swap_tac 0 2; rewrite par_in_pars.
  symmetry.
  swap_tac 0 4.
  swap_tac 2 4.
  rewrite (pars_split 3); simpl.
  rewrite dec_correct.
  rewrite -pars_cat //=.
  symmetry.
  swap_tac 0 (Out k).
  apply pars_cons_cong; rewrite //=.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
Qed.

End CPA.


Require Import List.
Import ListNotations.

Definition var := nat.
Definition eqb_var := Nat.eqb.
Definition covar := nat.
Definition eqb_covar := Nat.eqb.

Inductive term : Set :=
| tVar : var -> term
| tT : term
| tF : term
| tLam : var -> term -> term
| tMu : covar -> com -> term
with kont : Set :=
| kCovar : covar -> kont
| kStack : term -> kont -> kont
| kCond : com -> com -> kont
with com : Set :=
| cCom : term -> kont -> com.

Inductive ty : Set :=
| Tbool : ty
| Tarr : ty -> ty -> ty.

Definition ctxt : Type := list (var * ty).
Definition coctxt : Type := list (covar * ty).

Inductive term_typed : ctxt -> term -> ty -> coctxt -> Prop :=
| arrowR : forall Γ x v A B Δ,
    term_typed ((x,A) :: Γ) v B Δ ->
    term_typed Γ (tLam x v) (Tarr A B) Δ
| boolR1 : forall Γ Δ,
    term_typed Γ tT Tbool Δ
| boolR2 : forall Γ Δ,
    term_typed Γ tF Tbool Δ
| Ax : forall Γ x A Δ,
    term_typed ((x,A) :: Γ) (tVar x) A Δ
| ActR : forall c Γ α A Δ,
    com_typed c Γ ((α, A) :: Δ) ->
    term_typed Γ (tMu α c) A Δ
with kont_typed : ctxt -> kont -> ty -> coctxt -> Prop :=
| arrowL : forall Γ v E A B Δ,
    term_typed Γ v A Δ ->
    kont_typed Γ E B Δ ->
    kont_typed Γ (kStack v E) (Tarr A B) Δ
| boolL : forall Γ c1 c2 Δ,
    com_typed c1 Γ Δ ->
    com_typed c2 Γ Δ ->
    kont_typed Γ (kCond c1 c2) Tbool Δ
| CoAx : forall Γ α A Δ,
    kont_typed Γ (kCovar α) A ((α, A) :: Δ)
with com_typed : com -> ctxt -> coctxt -> Prop :=
| Cut : forall Γ v A Δ E,
    term_typed Γ v A Δ ->
    kont_typed Γ E A Δ ->
    com_typed (cCom v E) Γ Δ.

Notation "<[ G ⊢ V ; T | D ]>" := (term_typed G V T D) (at level 50).
Notation "<| G | E ; T ⊢ D |>" := (kont_typed G E T D) (at level 50).
Notation "<{ C ; ( G ⊢ D ) }>" := (com_typed C G D) (at level 50).

Lemma true_admits_bool: forall Γ Δ,
  <[ Γ ⊢ tT ; Tbool | Δ ]>.
Proof. constructor. Qed.

Lemma CoAx_holds : forall Γ α A Δ,
  <| Γ | (kCovar α) ; A ⊢ (α, A) :: Δ |>.
Proof. constructor. Qed.

Fixpoint subst_var_term (x : var) (M : term) (N : term) : term :=
  match N with
  | tVar y => if eqb_var x y then M else N
  | tT => tT
  | tF => tF
  | tLam y N' => if eqb_var x y then N else (tLam y (subst_var_term x M N'))
  | tMu α c => tMu α (subst_var_com x M c)
  end
with subst_var_kont (x : var) (M : term) (E : kont) : kont :=
  match E with
  | kCovar α => E
  | kStack N E' => kStack (subst_var_term x M N) (subst_var_kont x M E')
  | kCond c1 c2 => kCond (subst_var_com x M c1) (subst_var_com x M c2)
  end
with subst_var_com (x : var) (M : term) (c : com) : com :=
  match c with
  | cCom N E => cCom (subst_var_term x M N) (subst_var_kont x M E)
  end.

Notation "M ~ [ X ;= N ]" := (subst_var_term X M N) (at level 50).

Inductive final : com -> Prop :=
  | f_True : forall α,
      final (cCom tT (kCovar α))
  | f_False : forall α,
      final (cCom tF (kCovar α)).

Reserved Notation "t '→' t'" (at level 40).

Inductive step : com -> com -> Prop :=
  | step_True : forall c1 c2,
      step (cCom tT (kCond c1 c2)) c1
  | step_False : forall c1 c2,
      step (cCom tF (kCond c1 c2)) c2
  | step_Lam : forall x M N E,
      step (cCom (tLam x M) (kStack N E))
           (cCom ( M~[x;=N] ) E)
  (* ... *)
 where "t '→' t'" := (step t t').

Lemma progress : forall c α,
  <{ c ; ( [] ⊢ (α, Tbool) :: []) }> ->
  final c \/ exists c', c → c'.
Admitted.


(******************************************)
(*   Finite multiset library              *)
(*   Developped for the PACTOLE project   *)
(*   L. Rieg                              *)
(*                                        *)
(*   This file is distributed under       *)
(*   the terms of the CeCILL-C licence    *)
(*                                        *)
(******************************************)

Require Import RelationPairs.
Require Import MSetInterface.
Require Import Equalities.
Require Import SetoidPermutation.
Require Import MMultisets.Preliminary.

(** *  Signature of operations on multisets  **)

Module Type MMOps (E : DecidableType).

  Definition elt := E.t.
  Parameter t : Type.
  (** The types of elements and multisets. *)

  Parameter empty : t.
  (** The empty multiset. *)

  Parameter is_empty : t -> bool.
  (** Test whether a multiset is empty or not. *)

  Parameter multiplicity : elt -> t -> nat.
  (** [multiplicity x s] gives the number of occurences of [x] inside [s]. *)

  Parameter add : elt -> nat -> t -> t.
  (** [add x n s] returns a multiset containing all elements of s, plus [n] copies of [x]. *)
  (* If [n] is [0], should we return /exactly/ the original multiset? *)

  Parameter singleton : elt -> nat -> t.
  (** [singleton x n] returns the multiset containing only [n] copies of [x].
      It is [empty] if [n] is [0]. *)

  Parameter remove : elt -> nat -> t -> t.
  (** [remove x n s] returns a multiset containing all elements of s, minus [n] copies of [x].
      If the multiplicity of [x] in [s] is less than [n], we remove all the copies of [x] from [s]. *)

  Parameter union : t -> t -> t.
  (** Multiset union. *)

  Parameter inter : t -> t -> t.
  (** Multiset intersection. *)

  Parameter diff : t -> t -> t.
  (** Multiset difference. *)

  Parameter lub : t -> t -> t.
  (** Multiset lowest upper bound: the multiplicity of any [x] in [sup s1 s2] is the maximum of the multiplicities
  of [x] in [s1] and [s2]. *)

  Parameter equal : t -> t -> bool.
  (** [equal s1 s2] tests whether the multisets [s1] and [s2] are equal,
      that is, contain equal elements with equal multiplicities. *)

  Parameter subset : t -> t -> bool.
  (** [subset s1 s2] tests whether the multiset [s1] is a subset of the multiset [s2]. *)

  Parameter fold : forall {A : Type}, (elt -> nat -> A -> A) -> t -> A -> A.
  (** [fold f s a] computes [(f xN nN ... (f x2 n2 (f x1 n1 a))...)], where [x1 ... xN]
      are the distinct elements of [s] with respective positive multiplicities [n1 ... nN].
      The order in which the elements of [s] are presented to [f] is unspecified. *)

  Parameter for_all : (elt -> nat -> bool) -> t -> bool.
  (** [for_all p s] checks if all elements of the multiset (with their multiplicities) satisfy the predicate [p]. *)

  Parameter exists_ : (elt -> nat -> bool) -> t -> bool.
  (** [exists_ p s] checks if at least one element of the multiset (with its multiplicity)
      satisfies the predicate [p]. *)

  Parameter nfilter : (elt -> nat -> bool) -> t -> t.
  (** [nfilter p s] returns the multiset of all elements with multiplicity in [s] that satisfy the predicate [p]. *)

  Parameter filter : (elt -> bool) -> t -> t.
  (** [filter p s] returns the multiset of all elements in [s] that satisfy the predicate [p],
      keeping their multiplicity. *)

  Parameter npartition : (elt -> nat -> bool) -> t -> t * t.
  (** [partition p s] returns a pair of multisets [(s1, s2)], where [s1] is the multiset of all the elements of [s]
      with multiplicity that satisfy the predicate [p], and [s2] is the multiset of all the elements of [s] with
      multiplicity that do not satisfy [p]. *)

  Parameter partition : (elt -> bool) -> t -> t * t.
  (** [partition p s] returns a pair of multisets [(s1, s2)], where [s1] is the multiset of all the elements of [s]
      that satisfy the predicate [p], and [s2] is the multiset of all the elements of [s] that do not satisfy [p]. *)

  Parameter elements : t -> list (elt * nat).
  (** Return the list of all elements with multiplicity of the given multiset, in any order. *)

  Parameter support : t -> list elt.
  (** Return the list of all different elements without multiplicity of the given multiset, in any order. *)

  Parameter cardinal : t -> nat.
  (** Return the number of elements of a multiset, with multiplicity. *)

  Parameter size : t -> nat.
  (** Return the size of the support of a multiset,
      that is, the number of different elements (without multiplicity). *)

  Parameter choose : t -> option elt.
  (** Return one element of the given multiset, or [None] if the multiset is empty.
      Which element is chosen is unspecified: equal multisets could return different elements. *)
End MMOps.

(** *  Full signature for multisets  **)

Module Type MMultisetsOn (E : DecidableType).
  (** First, we ask for all the functions *)
  Include MMOps E.

  (** ** Logical predicates *)

  Definition In := fun x s => multiplicity x s > 0.

  Definition eq s s' := forall x, multiplicity x s = multiplicity x s'.
  Definition Subset s s' := forall x, multiplicity x s <= multiplicity x s'.
  Definition For_all (P : elt -> nat -> Prop) s := forall x, In x s -> P x (multiplicity x s).
  Definition Exists (P : elt -> nat -> Prop) s := exists x, In x s /\ P x (multiplicity x s).

  Global Notation "s  [=]  t" := (eq s t) (at level 70, no associativity, only parsing).
  Global Notation "m1  ≡  m2" := (eq m1 m2) (at level 70).
  Global Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity, only parsing).
  Global Notation "m1  ⊆  m2" := (Subset m1 m2) (at level 70).
  Global Notation "s [ x ]" := (multiplicity x s) (at level 2, no associativity, format "s [ x ]").

  (** ** Specifications of multiset operators *)

  Notation compatb := (Proper (E.eq ==> Logic.eq ==> @Logic.eq bool)) (only parsing).
  Declare Instance multiplicity_compat : Proper (E.eq ==> eq ==> Logic.eq) multiplicity.

  Declare Instance fold_compat A (eqA : A -> A -> Prop) `{Equivalence A eqA} :
    forall f, Proper (E.eq ==> Logic.eq ==> eqA ==> eqA) f -> transpose2 eqA f ->
    Proper (eq ==> eqA ==> eqA) (fold f).

  Parameter equal_spec : forall s s', equal s s' = true <-> s [=] s'.
  Parameter subset_spec : forall s s', subset s s' = true <-> s [<=] s'.
  Parameter empty_spec : forall x, empty[x] = 0.
  Parameter is_empty_spec : forall s, is_empty s = true <-> s [=] empty.
  Parameter add_same : forall x n s, (add x n s)[x] = s[x] + n.
  Parameter add_other : forall x y n s, ~E.eq y x -> (add x n s)[y] = s[y].
  Parameter remove_same : forall x n s, (remove x n s)[x] = s[x] - n.
  Parameter remove_other : forall x y n s, ~E.eq y x -> (remove x n s)[y] = s[y].
  Parameter singleton_same : forall x n, (singleton x n)[x] = n.
  Parameter singleton_other : forall x y n, ~E.eq y x -> (singleton x n)[y] = 0.
  Parameter union_spec : forall x s s', (union s s')[x] = s[x] + s'[x].
  Parameter inter_spec : forall x s s', (inter s s')[x] = min s[x] s'[x].
  Parameter diff_spec : forall x s s', (diff s s')[x] = s[x] - s'[x].
  Parameter lub_spec : forall x s s', (lub s s')[x] = max s[x] s'[x].
  Parameter fold_spec : forall (A : Type) s (i : A) (f : elt -> nat -> A -> A),
    fold f s i = fold_left (fun acc xn => f (fst xn) (snd xn) acc) (elements s) i.
  Parameter cardinal_spec : forall s, cardinal s = fold (fun x n acc => n + acc) s 0.
  Parameter size_spec : forall s, size s = length (support s).
  Parameter nfilter_spec : forall f x s, compatb f -> (nfilter f s)[x] = if f x s[x] then s[x] else 0.
  Parameter filter_spec : forall f x s, Proper (E.eq ==> Logic.eq) f -> (filter f s)[x] = if f x then s[x] else 0.
  Parameter for_all_spec : forall f s, compatb f -> (for_all f s = true <-> For_all (fun x n => f x n = true) s).
  Parameter exists_spec : forall f s, compatb f -> (exists_ f s = true <-> Exists (fun x n => f x n = true) s).
  Parameter npartition_spec_fst : forall f s, compatb f -> fst (npartition f s) [=] nfilter f s.
  Parameter npartition_spec_snd : forall f s, compatb f ->
    snd (npartition f s) [=] nfilter (fun x n => negb (f x n)) s.
  Parameter partition_spec_fst : forall f s, Proper (E.eq ==> Logic.eq) f -> fst (partition f s) [=] filter f s.
  Parameter partition_spec_snd : forall f s, Proper (E.eq ==> Logic.eq) f ->
    snd (partition f s) [=] filter (fun x => negb (f x)) s.

  Definition eq_pair := RelProd E.eq (@Logic.eq nat).
  Definition eq_elt := RelCompFun E.eq (@fst E.t nat).

  Instance eq_pair_equiv : Equivalence eq_pair.
  Proof. split.
  intros [x n]. now split; hnf.
  intros [x n] [y m] [H1 H2]; split; hnf in *; now auto.
  intros ? ? ? [? ?] [? ?]. split. hnf in *. now transitivity (fst y). now transitivity (snd y).
  Qed.

  Parameter elements_spec : forall x n s, InA eq_pair (x, n) (elements s) <-> s[x] = n /\ n > 0.
  Parameter elements_NoDupA : forall s, NoDupA eq_elt (elements s).
  Parameter support_spec : forall x s, InA E.eq x (support s) <-> In x s.
  Parameter support_NoDupA : forall s, NoDupA E.eq (support s).

  Parameter choose_Some : forall x s, choose s = Some x -> In x s.
  Parameter choose_None : forall s, choose s = None <-> s [=] empty.
End MMultisetsOn.

(** **  Signature on an ordered type  **)

Module Type Sord (E : OrderedType).

  (** We include all the common interface *)
  Include MMultisetsOn E.

  (** Orders on elements *)
  Definition lt_elt (xn yp : elt * nat) := E.lt (fst xn) (fst yp).

  Parameter elements_Sorted : forall s, Sorted lt_elt (elements s).

  (** Multiset ordering is left as future works *)

(*
  Include HasLt <+ IsEq <+ IsStrOrder.

  Definition cmp := Nat.eqb.

  Parameter compare : t -> t -> comparison.

  Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2).
*)
End Sord.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : natural) (lf2 : lst) (x : lst) : natural :=
  Succ (double (len x)).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus Zero lf1.


Require Export ZArith.BinIntDef.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Lists.List.
From BSC Require Export Replace.

Module Lang.
Import Z.
Local Open Scope Z.
Definition id := nat.

(* Types *)
Inductive ty : Type :=
| Ty_Unit : ty               (* Unit *)
| Ty_Bool : ty               (* Boolean *)
| Ty_Int : ty                (* Integer *)
| Ty_Prod : ty -> ty -> ty   (* Product *)
| Ty_Sum : ty -> ty -> ty    (* Sum *)
| Ty_Arrow : ty -> ty -> ty  (* Function *)
| Ty_Var : id -> ty          (* Type Variable *)
| Ty_Forall : ty -> ty       (* Universal Type *)
| Ty_Some : ty -> ty         (* Existential Type *)
| Ty_Rec : ty -> ty          (* Recursive Type *)
| Ty_Ref : ty -> ty          (* Reference Type *).

Definition context := list ty.
Definition empty : list ty := nil.

(* Binary Operators  *)
Inductive bop : Type :=
| Op_Add : bop  (* Addition "+" *)
| Op_Mult : bop (* Multiplication "*" *)
| Op_Sub : bop  (* Substraction "-" *)
| Op_Lt : bop   (* Less-Than "<" *)
| Op_Eq : bop   (* Equal "=" *).

(* Typing of Binary Operators  *)
Definition bop_ty bop : ty :=
  match bop with
  | Op_Add | Op_Mult | Op_Sub => Ty_Arrow (Ty_Prod Ty_Int Ty_Int) Ty_Int
  | Op_Lt | Op_Eq => Ty_Arrow (Ty_Prod Ty_Int Ty_Int) Ty_Bool
  end.

(* Expressions *)
Inductive expr : Type :=
(* Unit *)
| e_unit : expr
(* Booleans *)
| e_true : expr
| e_false : expr
| e_if : expr -> expr -> expr -> expr
(* Arithmetic *)
| e_const : Z -> expr
| e_binop : bop -> expr -> expr -> expr
(* Pairs *)
| e_pair : expr -> expr -> expr
| e_fst : expr -> expr
| e_snd : expr -> expr
(* Sums *)
| e_inl : expr -> expr
| e_inr : expr -> expr
| e_case : expr -> expr -> expr -> expr
(* STLC with recursion *)
| e_var : id -> expr
| e_app : expr -> expr -> expr
| e_rec :  expr -> expr
(* Polymorphism *)
| e_tapp : expr -> expr
| e_tabs : expr -> expr
(* Existentials *)
| e_pack : expr -> expr
| e_unpack : expr -> expr -> expr
(* Recursive Types *)
| e_fold : expr -> expr
| e_unfold : expr -> expr
(* References *)
| e_loc : nat -> expr
| e_alloc : expr -> expr
| e_assign : expr -> expr -> expr
| e_load : expr -> expr.

Global Hint Constructors expr : core.

(* Computation of binary expressions  *)
Definition compute_bop (op : bop) (i j : Z) : expr :=
  match op with
  | Op_Add => e_const (i + j)
  | Op_Mult => e_const (i * j)
  | Op_Sub => e_const (i - j)
  | Op_Lt => if (i <? j) then e_true else e_false
  | Op_Eq => if (i =? j) then e_true else e_false
  end.

(* Values *)
Inductive value : expr -> Prop :=
| v_unit : value e_unit
| v_int : forall i, value (e_const i)
| v_true : value e_true
| v_false : value e_false
| v_pair : forall v0 v1, value v0 -> value v1 -> value (e_pair v0 v1)
| v_inl : forall v, value v -> value (e_inl v)
| v_inr : forall v, value v -> value (e_inr v)
| v_rec : forall e, value (e_rec e)
| v_tabs : forall e, value (e_tabs e)
| v_pack : forall v, value v -> value (e_pack v)
| v_fold : forall v, value v -> value (e_fold v)
| v_loc : forall l, value (e_loc l).

Global Hint Constructors value : core.

Local Open Scope nat.

(* shift d from c in type T *)
Fixpoint tshift (d : id) (c : id) (T : ty) : ty :=
  match T with
  | Ty_Unit => Ty_Unit
  | Ty_Bool => Ty_Bool
  | Ty_Int => Ty_Int
  | Ty_Prod T1 T2 => Ty_Prod (tshift d c T1) (tshift d c T2)
  | Ty_Sum T1 T2 => Ty_Sum (tshift d c T1) (tshift d c T2)
  | Ty_Arrow T1 T2 => Ty_Arrow (tshift d c T1) (tshift d c T2)
  | Ty_Var k => if (k <? c) then Ty_Var k else Ty_Var (k+d)
  | Ty_Forall T1 => Ty_Forall (tshift d (S c) T1)
  | Ty_Some T1 => Ty_Some (tshift d (S c) T1)
  | Ty_Rec T1 => Ty_Rec (tshift d (S c) T1)
  | Ty_Ref T1 => Ty_Ref (tshift d c T1)
  end.

(* shift d from c in expression e *)
Fixpoint shift (d : id) (c : id) (e : expr) : expr :=
  match e with
  | e_var k => if (k <? c) then e_var k else e_var (k+d)
  | e_app e0 e1 => e_app (shift d c e0) (shift d c e1)
  | e_unit => e_unit
  | e_true => e_true
  | e_false => e_false
  | e_if e0 e1 e2 => e_if (shift d c e0) (shift d c e1) (shift d c e2)
  | e_const i => e_const i
  | e_binop op e0 e1 => e_binop op (shift d c e0) (shift d c e1)
  | e_pair e0 e1 => e_pair (shift d c e0) (shift d c e1)
  | e_fst e0 => e_fst (shift d c e0)
  | e_snd e1 => e_snd (shift d c e1)
  | e_inl e0 => e_inl (shift d c e0)
  | e_inr e1 => e_inr (shift d c e1)
  | e_case e0 e1 e2 => e_case (shift d c e0)
                              (shift d (S c) e1)
                              (shift d (S c) e2)
  | e_rec e0 => e_rec (shift d (S (S c)) e0)
  | e_tapp e0 => e_tapp (shift d c e0)
  | e_tabs e0 => e_tabs (shift d c e0)
  | e_pack e0 => e_pack (shift d c e0)
  | e_unpack e0 e1 => e_unpack (shift d c e0) (shift d (S c) e1)
  | e_fold e0 => e_fold (shift d c e0)
  | e_unfold e0 => e_unfold (shift d c e0)
  | e_loc l => e_loc l
  | e_alloc e0 => e_alloc (shift d c e0)
  | e_assign e0 e1 => e_assign (shift d c e0) (shift d c e1)
  | e_load e0 => e_load (shift d c e0)
  end.

(* Substitute j with X in type T
 * Worth noting: In the Ty_Var case the double conditional
 *               circumvents the need to shift -1.
 *)
Fixpoint tsubst (j : id) (X : ty) (T : ty) : ty :=
  match T with
  | Ty_Unit => Ty_Unit
  | Ty_Bool => Ty_Bool
  | Ty_Int => Ty_Int
  | Ty_Prod T1 T2 => Ty_Prod (tsubst j X T1) (tsubst j X T2)
  | Ty_Sum T1 T2 => Ty_Sum (tsubst j X T1) (tsubst j X T2)
  | Ty_Arrow T1 T2 => Ty_Arrow (tsubst j X T1) (tsubst j X T2)
  | Ty_Var k => if (k =? j) then X else (if (k <? j) then T else Ty_Var (k-1))
  | Ty_Forall T1 => Ty_Forall (tsubst (S j) (tshift 1 0 X) T1)
  | Ty_Some T1 => Ty_Some (tsubst (S j) (tshift 1 0 X) T1)
  | Ty_Rec T1 => Ty_Rec (tsubst (S j) (tshift 1 0 X) T1)
  | Ty_Ref T1 => Ty_Ref (tsubst j X T1)
  end.

(* Substitute j with s in e
 * Worth noting: In the e_var case the double conditional
 *               circumvents the need to shift -1.
 *)
Fixpoint subst (j : id) (s : expr) (e : expr) : expr :=
  match e with
  | e_var k => if (k =? j) then s else (if (k <? j) then e else e_var (k-1))
  | e_app e1 e2 => e_app (subst j s e1) (subst j s e2)
  | e_rec e1 => e_rec (subst (S (S j)) (shift 2 0 s) e1)
  | e_unit => e_unit
  | e_true => e_true
  | e_false => e_false
  | e_if e1 e2 e3 => e_if (subst j s e1) (subst j s e2) (subst j s e3)
  | e_const i => e_const i
  | e_binop bop e1 e2 => e_binop bop (subst j s e1) (subst j s e2)
  | e_pair e1 e2 => e_pair (subst j s e1) (subst j s e2)
  | e_fst e1 => e_fst (subst j s e1)
  | e_snd e2 => e_snd (subst j s e2)
  | e_inl e1 => e_inl (subst j s e1)
  | e_inr e2 => e_inr (subst j s e2)
  | e_case e1 e2 e3 => e_case (subst j s e1)
                              (subst (S j) (shift 1 0 s) e2)
                              (subst (S j) (shift 1 0 s) e3)
  | e_tapp e1 => e_tapp (subst j s e1)
  | e_tabs e1 => e_tabs (subst j s e1)
  | e_pack e1 => e_pack (subst j s e1)
  | e_unpack e1 e2 => e_unpack (subst j s e1) (subst (S j) (shift 1 0 s) e2)
  | e_fold e1 => e_fold (subst j s e1)
  | e_unfold e1 => e_unfold (subst j s e1)
  | e_loc l => e_loc l
  | e_alloc e1 => e_alloc (subst j s e1)
  | e_assign e1 e2 => e_assign (subst j s e1) (subst j s e2)
  | e_load e1 => e_load (subst j s e1)
  end.

Definition store_ty := list ty.

(* This is to make Coq more cooperative.
 * The None case does not actually appear in typing, *)
Definition store_ty_lookup (Σ : store_ty) (l : nat) :=
  match nth_error Σ l with
  | Some T => T
  | None => Ty_Unit
  end.

(* Typing Relation  *)
Inductive has_type (Σ : store_ty) : context -> expr -> ty -> Prop :=
(* STLC with recursion  *)
| T_Var : forall Γ k T,
    nth_error Γ k = Some T -> has_type Σ Γ (e_var k) T
| T_App : forall Γ T1 T2 e1 e2,
    has_type Σ Γ e1 (Ty_Arrow T2 T1) ->
    has_type Σ Γ e2 T2 ->
    has_type Σ Γ (e_app e1 e2) T1
| T_Rec : forall Γ T1 T2 e,
    has_type Σ ((Ty_Arrow T2 T1)::T2::Γ) e T1 ->
    has_type Σ Γ (e_rec e) (Ty_Arrow T2 T1)
(* Unit *)
| T_Unit : forall Γ, has_type Σ Γ e_unit Ty_Unit
(* Booleans *)
| T_True : forall Γ, has_type Σ Γ e_true Ty_Bool
| T_False : forall Γ, has_type Σ Γ e_false Ty_Bool
| T_If : forall Γ e1 e2 e3 T,
    has_type Σ Γ e1 Ty_Bool ->
    has_type Σ Γ e2 T ->
    has_type Σ Γ e3 T ->
    has_type Σ Γ (e_if e1 e2 e3) T
(* Integers and Arithmetic *)
| T_Int : forall Γ i, has_type Σ Γ (e_const i) Ty_Int
| T_Binop : forall Γ bop e1 e2 T1 T2 T3,
    bop_ty bop = Ty_Arrow (Ty_Prod T1 T2) T3 ->
    has_type Σ Γ e1 T1 ->
    has_type Σ Γ e2 T2 ->
    has_type Σ Γ (e_binop bop e1 e2) T3
(* Products *)
| T_Pair : forall Γ T1 T2 e1 e2,
    has_type Σ Γ e1 T1 ->
    has_type Σ Γ e2 T2 ->
    has_type Σ Γ (e_pair e1 e2) (Ty_Prod T1 T2)
| T_Fst : forall Γ T1 T2 e,
    has_type Σ Γ e (Ty_Prod T1 T2) ->
    has_type Σ Γ (e_fst e) T1
| T_Snd : forall Γ T1 T2 e,
    has_type Σ Γ e (Ty_Prod T1 T2) ->
    has_type Σ Γ (e_snd e) T2
(* Sums *)
| T_Inl : forall Γ T1 T2 e,
    has_type Σ Γ e T1 ->
    has_type Σ Γ (e_inl e) (Ty_Sum T1 T2)
| T_Inr : forall Γ T1 T2 e,
    has_type Σ Γ e T2 ->
    has_type Σ Γ (e_inr e) (Ty_Sum T1 T2)
| T_Case : forall Γ T1 T2 T3 e0 e1 e2,
    has_type Σ Γ e0 (Ty_Sum T1 T2) ->
    has_type Σ (T1::Γ) e1 T3 ->
    has_type Σ (T2::Γ) e2 T3 ->
    has_type Σ Γ (e_case e0 e1 e2) T3
(* Polymorphism *)
| T_Tabs : forall Γ T e,
    has_type (map (tshift 1 0) Σ) (map (tshift 1 0) Γ) e T ->
    has_type Σ Γ (e_tabs e) (Ty_Forall T)
| T_Tapp : forall Γ T1 T2 e,
    has_type Σ Γ e (Ty_Forall T1) ->
    has_type Σ Γ (e_tapp e) (tsubst 0 T2 T1)
(* Existentials *)
| T_Pack : forall Γ T1 T2 e,
    has_type Σ Γ e (tsubst 0 T1 T2) ->
    has_type Σ Γ (e_pack e) (Ty_Some T2)
| T_Unpack : forall Γ T1 T2 e1 e2,
    has_type Σ Γ e1 (Ty_Some T1) ->
    has_type (map (tshift 1 0) Σ) (T1::(map (tshift 1 0) Γ)) e2 (tshift 1 0 T2) ->
    has_type Σ Γ (e_unpack e1 e2) T2
(* Recursives *)
| T_Fold : forall Γ T e,
    has_type Σ Γ e (tsubst 0 (Ty_Rec T) T) ->
    has_type Σ Γ (e_fold e) (Ty_Rec T)
| T_Unfold : forall Γ T e,
    has_type Σ Γ e (Ty_Rec T) ->
    has_type Σ Γ (e_unfold e) (tsubst 0 (Ty_Rec T) T)
(* References
 * Note: l < length Σ models l ∈ dom(Σ) *)
| T_Loc : forall Γ l,
    l < length Σ ->
    has_type Σ Γ (e_loc l) (Ty_Ref (store_ty_lookup Σ l))
| T_Alloc : forall Γ T e,
    has_type Σ Γ e T ->
    has_type Σ Γ (e_alloc e) (Ty_Ref T)
| T_Assign : forall Γ T e1 e2,
    has_type Σ Γ e1 (Ty_Ref T) ->
    has_type Σ Γ e2 T ->
    has_type Σ Γ (e_assign e1 e2) (Ty_Unit)
| T_Load : forall Γ T e,
    has_type Σ Γ e (Ty_Ref T) ->
    has_type Σ Γ (e_load e) T.

Global Hint Constructors has_type : core.

Definition relation (X : Type) := X -> X -> Prop.
Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Definition store := list expr.
Definition store_lookup (σ : store) (l : nat) :=
  match nth_error σ l with
  | Some v => v
  | None => e_unit
  end.

Reserved Notation "e '-->' e'" (at level 40).

Inductive step : store * expr -> store * expr -> Prop :=
(* Function Application *)
| ST_AppRec : forall σ e v,
    value v ->
    (σ, e_app (e_rec e) v) --> (σ, subst 0 v (subst 0 (shift 1 0 (e_rec e)) e))
| ST_App1 : forall σ σ' e1 e1' e2,
    (σ, e1) --> (σ', e1') ->
    (σ, e_app e1 e2) --> (σ', e_app e1' e2)
| ST_App2 : forall σ σ' v1 e2 e2',
    value v1 ->
    (σ, e2) --> (σ', e2') ->
    (σ, e_app v1 e2) --> (σ', e_app v1 e2')
(* Binary Operations *)
| ST_Binop1 : forall σ σ' op e1 e1' e2,
    (σ, e1) --> (σ', e1') ->
    (σ, e_binop op e1 e2) --> (σ', e_binop op e1' e2)
| ST_Binop2 : forall σ σ' op v1 e2 e2',
    value v1 ->
    (σ, e2) --> (σ', e2') ->
    (σ, e_binop op v1 e2) --> (σ', e_binop op v1 e2')
| ST_Binop3 : forall σ op v1 v2,
    (σ, e_binop op (e_const v1) (e_const v2)) --> (σ, compute_bop op v1 v2)
(* If-Then-Else  *)
| ST_If : forall σ σ' e1 e1' e2 e3,
    (σ, e1) --> (σ', e1') ->
    (σ, e_if e1 e2 e3) --> (σ', e_if e1' e2 e3)
| ST_IfTrue : forall σ e2 e3,
    (σ, e_if e_true e2 e3) --> (σ, e2)
| ST_IfFalse : forall σ e2 e3,
    (σ, e_if e_false e2 e3) --> (σ, e3)
(* Products *)
| ST_Pair1 : forall σ σ' e1 e1' e2,
    (σ, e1) --> (σ', e1') ->
    (σ, e_pair e1 e2) --> (σ', e_pair e1' e2)
| ST_Pair2 : forall σ σ' v1 e2 e2',
    value v1 ->
    (σ, e2) --> (σ', e2') ->
    (σ, e_pair v1 e2) --> (σ', e_pair v1 e2')
| ST_Fst1 : forall σ σ' e1 e1',
    (σ, e1) --> (σ', e1') ->
    (σ, e_fst e1) --> (σ', e_fst e1')
| ST_Fst2 : forall σ v1 v2,
    value v1 ->
    value v2 ->
    (σ, e_fst (e_pair v1 v2)) --> (σ, v1)
| ST_Snd1 : forall σ σ' e1 e1',
    (σ, e1) --> (σ', e1') ->
    (σ, e_snd e1) --> (σ', e_snd e1')
| ST_Snd2 : forall σ v1 v2,
    value v1 ->
    value v2 ->
    (σ, e_snd (e_pair v1 v2)) --> (σ, v2)
(* Sums *)
| ST_Inl : forall σ σ' e1 e1',
    (σ, e1) --> (σ', e1') ->
    (σ, e_inl e1) --> (σ', e_inl e1')
| ST_Inr : forall σ σ' e2 e2',
    (σ, e2) --> (σ', e2') ->
    (σ, e_inr e2) --> (σ', e_inr e2')
| ST_Case : forall σ σ' e1 e1' e2 e3,
    (σ, e1) --> (σ', e1') ->
    (σ, e_case e1 e2 e3) --> (σ', e_case e1' e2 e3)
| ST_CaseInl : forall σ v1 e2 e3,
    value v1 ->
    (σ, e_case (e_inl v1) e2 e3) --> (σ, subst 0 v1 e2)
| ST_CaseInr : forall σ v2 e2 e3,
    value v2 ->
    (σ, e_case (e_inr v2) e2 e3) --> (σ, subst 0 v2 e3)
(* Polymorphism *)
| ST_TApp : forall σ σ' e1 e1',
    (σ, e1) --> (σ', e1') ->
    (σ, e_tapp e1) --> (σ', e_tapp e1')
| ST_TAppAbs : forall σ e,
    (σ, e_tapp (e_tabs e)) --> (σ, e)
(* Existentials *)
| ST_Pack : forall σ σ' e1 e1',
    (σ, e1) --> (σ', e1') ->
    (σ, e_pack e1) --> (σ', e_pack e1')
| ST_Unpack : forall σ σ' e1 e1' e2,
    (σ, e1) --> (σ', e1') ->
    (σ, e_unpack e1 e2) --> (σ', e_unpack e1' e2)
| ST_UnpackPack : forall σ v1 e2,
    value v1 ->
    (σ, e_unpack (e_pack v1) e2) --> (σ, subst 0 v1 e2)
(* Recursives *)
| ST_UnfoldFold : forall σ v,
    value v ->
    (σ, e_unfold (e_fold v)) --> (σ, v)
| ST_Fold : forall σ σ' e e',
    (σ, e) --> (σ', e') ->
    (σ, e_fold e) --> (σ', e_fold e')
| ST_Unfold : forall σ σ' e e',
    (σ, e) --> (σ', e') ->
    (σ, e_unfold e) --> (σ', e_unfold e')
(* References *)
| ST_Alloc : forall σ σ' e e',
    (σ, e) --> (σ', e') ->
    (σ, e_alloc e) --> (σ', e_alloc e')
| ST_AllocValue : forall σ v,
    value v ->
    (σ, e_alloc v) --> (σ++(v::nil), e_loc (length σ))
| ST_Assign1 : forall σ σ' e1 e1' e2,
    (σ, e1) --> (σ', e1') ->
    (σ, e_assign e1 e2) --> (σ', e_assign e1' e2)
| ST_Assign2 : forall σ σ' v e2 e2',
    value v ->
    (σ, e2) --> (σ', e2') ->
    (σ, e_assign v e2) --> (σ', e_assign v e2')
| ST_AssignValue : forall σ l v,
    value v ->
    l < length σ ->
    (σ, e_assign (e_loc l) v) --> (replace l v σ, e_unit)
| ST_Load : forall σ σ' e e',
    (σ, e) --> (σ', e') ->
    (σ, e_load e) --> (σ', e_load e')
| ST_LoadLoc : forall σ l,
    l < length σ ->
    (σ, e_load (e_loc l)) --> (σ, store_lookup σ l)
where "e '-->' e'" := (step e e').

Notation "e '-->*' e'" := (multi step e e') (at level 40).

(** Notation Settings. **)

(* Notation is a modified version of the
** notation found in the Sofware Foundations Programming Languages book *)
Declare Custom Entry ks.
Declare Custom Entry ks_ty.

Notation "<{ e }>" := e (e custom ks at level 99).
Notation "<{{ e }}>" := e (e custom ks_ty at level 99).
Notation "( x )" := x (in custom ks, x at level 99).
Notation "( x )" := x (in custom ks_ty, x at level 99).
Notation "x" := x (in custom ks at level 0, x constr at level 0).
Notation "x" := x (in custom ks_ty at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom ks_ty at level 50, right associativity).
Notation "x y" := (e_app x y) (in custom ks at level 1, left associativity).
Notation "'λ' , y" := (e_rec y) (in custom ks at level 90,
                                    y custom ks at level 99,
                                    left associativity).
Notation "# n" := (e_var (n%nat)) (in custom ks at level 99).
Coercion e_const : Z >-> expr.

Notation "'Int'" := Ty_Int (in custom ks_ty at level 0).
Notation "x + y" := (e_binop Op_Add x y) (in custom ks at level 1,
                                      x custom ks,
                                      y custom ks,
                                      left associativity).
Notation "x * y" := (e_binop Op_Mult x y) (in custom ks at level 1,
                                      x custom ks,
                                      y custom ks,
                                      left associativity).
Notation "x - y" := (e_binop Op_Sub x y) (in custom ks at level 1,
                                      x custom ks,
                                      y custom ks,
                                      left associativity).
Notation "x < y" := (e_binop Op_Lt x y) (in custom ks at level 1,
                                      x custom ks,
                                      y custom ks,
                                      left associativity).
Notation "x = y" := (e_binop Op_Eq x y) (in custom ks at level 1,
                                      x custom ks,
                                      y custom ks,
                                      left associativity).

Notation "S + T" := (Ty_Sum S T) (in custom ks_ty at level 3, left associativity).
Notation "'inl' e" := (e_inl e) (in custom ks at level 0,
                                        e custom ks at level 0).
Notation "'inr' e" := (e_inr e) (in custom ks at level 0,
                                        e custom ks at level 0).
Notation "'case' e0 'of' '|' 'inl' e1 '|' 'inr' e2" :=
  (e_case e0 e1 e2) (in custom ks at level 89,
                               e0 custom ks at level 99,
                               e1 custom ks at level 99,
                               e2 custom ks at level 99,
                               left associativity).

Notation "S * T" := (Ty_Prod S T) (in custom ks_ty at level 2,
                                      S custom ks_ty,
                                      T custom ks_ty at level 0).
Notation "( x ',' y )" := (e_pair x y) (in custom ks at level 0,
                                           x custom ks at level 99,
                                           y custom ks at level 99).
Notation "e '.fst'" := (e_fst e) (in custom ks at level 0).
Notation "e '.snd'" := (e_snd e) (in custom ks at level 0).

Notation "'Unit'" := (Ty_Unit) (in custom ks_ty at level 0).
Notation "'unit'" := (e_unit) (in custom ks at level 0).

Notation "'Bool'" := (Ty_Bool) (in custom ks_ty at level 0).
Notation "'true'" := (e_true) (in custom ks at level 0).
Notation "'false'" := (e_false) (in custom ks at level 0).
Notation "'if' e0 'then' e1 'else' e2" := (e_if e0 e1 e2) (in custom ks at level 89,
                                                              e0 custom ks at level 99,
                                                              e1 custom ks at level 99,
                                                              e2 custom ks at level 99).

Notation "'[' # j ':=' s ']' e" := (subst (j%nat) s e) (in custom ks at level 20).

Notation "@ n" := (Ty_Var n%nat) (in custom ks_ty at level 99).
Notation "'∀X,' T" := (Ty_Forall T) (in custom ks_ty at level 2,
                                        T custom ks_ty at level 0).
Notation "'∃X,' T" := (Ty_Some T) (in custom ks_ty at level 2,
                                      T custom ks_ty at level 0).
Notation "'[|' @ j '/' X '|]' T" := (tsubst (j%nat) X T) (in custom ks_ty at level 20).
Notation "'Λ' e" := (e_tabs e) (in custom ks at level 0,
                                 e custom ks at level 0).
Notation "e '_'" := (e_tapp e) (in custom ks at level 30).
Notation "'pack' e" := (e_pack e) (in custom ks at level 30).
Notation "'unpack' e 'in' e'" := (e_unpack e e') (in custom ks at level 89,
                                                     e custom ks at level 99,
                                                     e' custom ks at level 99).
Notation "'fold' e" := (e_fold e) (in custom ks at level 30).
Notation "'unfold' e" := (e_unfold e) (in custom ks at level 30).

End Lang.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Coq.Relations.Relation_Definitions.
Require Import SetoidClass.
Require Import Reals.

Open Scope R_scope.

Definition operation A := A -> A -> A.

Class Associative {A : Type} (rel : relation A) (O : operation A) :=
 op_assoc : forall x y z, rel (O x (O y z)) (O (O x y) z).

Class Commutative {A : Type} (rel : relation A) (O : operation A) :=
 op_comm : forall x y, rel (O x y) (O y x).

Definition scalar A B := A -> B -> B.

Definition value A := A -> R.

Class Metric_Space (A : Type) (eqA : relation A) (d : A -> A -> R) := {
  metric_space_setoid :> Equivalence eqA ;
  metric_space_positive : forall x y : A, 0 <= d x y ;
  metric_space_symmetry : forall x y : A, d x y = d y x ;
  metric_space_separation : forall x y : A, (0 = d x y -> eqA x y) /\ (eqA x y -> 0 = d x y);
  metric_space_triangular_inequality : forall x y z : A, d x z <= (d x y) + (d y z)
}.

Class Monoid (M : Type) (eqM : relation M) (f : operation M) (eps : M) := {
  monoid_setoid :> Equivalence eqM ;
  monoid_iden_l : forall x : M, eqM (f eps x) x ;
  monoid_iden_r : forall x : M, eqM (f x eps) x ;
  monoid_assoc :> Associative eqM f;
  monoid_eq_compat_l : forall x y z : M, eqM y z -> eqM (f x y) (f x z);
  monoid_eq_compat_r: forall x y z : M, eqM x y -> eqM (f x z) (f y z)
}.

Class Monoid_Commutative (M : Type) (eqM : relation M) (f : operation M) (eps : M) := {
  monoid_comm_monoid :> Monoid M eqM f eps ;
  monoid_comm :> Commutative eqM f
}.

Class Group (G : Type) (eqG : relation G) (f : operation G) (eps : G) := {
  group_monoid :> Monoid G eqG f eps;
  group_reverse : forall x : G, sig (fun y => eqG (f x y) eps)
}.

Class Group_Commutative (G : Type) (eqG : relation G) (f : operation G) (eps : G) := {
  group_comm_group :> Group G eqG f eps ;
  group_comm :> Commutative eqG f
}.

Class Group_Multiplicative (G : Type) (eqG : relation G) (mult : operation G) (eps0 : G) (eps1 : G) := {
  group_setoid :> Equivalence eqG ;
  group_multiplicative_iden_l : forall x : G, eqG (mult eps1 x) x ;
  group_multiplicative_iden_r : forall x : G, eqG (mult x eps1) x ;
  group_multiplicative_reverse : forall x : G, ~(eqG x eps0) -> sig (fun y => eqG (mult x y) eps1);
  group_multiplicative_assoc :> Associative eqG mult;
  group_multiplicative_eq_compat_l : forall x y z : G, eqG y z -> eqG (mult x y) (mult x z);
  group_multiplicative_eq_compat_r: forall x y z : G, eqG x y -> eqG (mult x z) (mult y z)
}.

Class SemiRing (S : Type) (eqS : relation S) (add : operation S) (mult : operation S) (eps0 : S) (eps1 : S) := {
  semiring_monoid_comm :> Monoid_Commutative S eqS add eps0 ;
  semiring_monoid :> Monoid S eqS mult eps1 ;
  semiring_distributive_r : forall x y z : S, eqS (mult x (add y z)) (add (mult x y) (mult x z)) ;
  semiring_distributive_l : forall x y z : S, eqS (mult (add x y) z) (add (mult x z) (mult y z)) ;
  semiring_absorption_r : forall x : S, eqS (mult x eps0) eps0 ;
  semiring_absorption_l : forall x : S, eqS (mult eps0 x) eps0
}.

Class SemiRing_Commutative (S : Type) (eqS : relation S) (add : operation S) (mult : operation S) (eps0 : S) (eps1 : S) := {
  semiring_comm_semiring :> SemiRing S eqS add mult eps0 eps1 ;
  semiring_comm :> Commutative eqS mult
}.

Class Ring (R : Type) (eqR : relation R) (add : operation R) (mult : operation R) (eps0 : R) (eps1 : R) := {
  ring_group_comm :> Group_Commutative R eqR add eps0 ;
  ring_monoid :> Monoid R eqR mult eps1 ;
  ring_distributive_r : forall x y z : R, eqR (mult x (add y z)) (add (mult x y) (mult x z)) ;
  ring_distributive_l : forall x y z : R, eqR (mult (add x y) z) (add (mult x z) (mult y z))
}.

Class Ring_Commutative (R : Type) (eqR : relation R) (add : operation R) (mult : operation R) (eps0 : R) (eps1 : R) := {
  ring_comm_ring :> Ring R eqR add mult eps0 eps1 ;
  ring_comm :> Commutative eqR mult
}.

Class Field (F : Type) (eqF : relation F) (add : operation F) (mult : operation F) (eps0 : F) (eps1 : F) := {
  field_group_comm :> Group_Commutative F eqF add eps0 ;
  field_group_multiplicative :> Group_Multiplicative F eqF mult eps0 eps1 ;
  field_distributive_r : forall x y z : F, eqF (mult x (add y z)) (add (mult x y) (mult x z)) ;
  field_distributive_l : forall x y z : F, eqF (mult (add x y) z) (add (mult x z) (mult y z))
}.

Class Field_Commutative (F : Type) (eqF : relation F) (add : operation F) (mult : operation F) (eps0 : F) (eps1 : F) := {
  field_comm_field :> Field F eqF add mult eps0 eps1 ;
  field_comm :> Commutative eqF mult
}.

Class Field_Valued (F : Type) (eqF : relation F) (add : operation F) (mult : operation F) (eps0 : F) (eps1 : F) (abs : value F) := {
  field_valued_field_commutative :> Field_Commutative F eqF add mult eps0 eps1 ;
  field_valued_positive : forall x : F, 0 <= (abs x) ;
  field_valued_separation : (abs eps0) = 0 /\ forall x : F, (abs x) = 0 -> eqF x eps0 ;
  field_valued_triangular_inequality : forall x y : F, abs (add x y) <= (abs x) + (abs y);
  field_valued_homogeneity : forall x y : F, abs (mult x y) = (abs x) * (abs y)
}.

Class Vector_Space (E : Type) (eqE : relation E) (F : Type) (eqF : relation F)
                                 (v_add : operation E) (v_mult : scalar F E)
                                 (add : operation F) (mult : operation F)
                                 (v_null : E)
                                 (eps0 : F) (eps1 : F):= {
  vector_space_field :> Field_Commutative F eqF add mult eps0 eps1 ;
  vector_space_group_comm :> Group_Commutative E eqE v_add v_null ;
  vector_space_distributive_r : forall a : F, forall x y : E, eqE (v_mult a (v_add x y)) (v_add (v_mult a x) (v_mult a y)) ;
  vector_space_distributive_l : forall a b : F, forall x : E, eqE (v_mult (add a b) x) (v_add (v_mult a x) (v_mult b x)) ;
  vector_space_assoc : forall a b : F, forall x : E, eqE (v_mult (mult a b) x) (v_mult a (v_mult b x)) ;
  vector_space_iden_l : forall a : F, forall x : E, eqE (v_mult eps1 x) x;
  vector_space_eq_compat_l : forall a : F, forall x y :E, eqE x y -> eqE (v_mult a x) (v_mult a y);
  vector_space_eq_compat_r : forall a b : F, forall x : E, eqF a b -> (eqE (v_mult a x) (v_mult b x))
}.

Class Vector_Space_Normed (E : Type) (eqE : relation E) (F : Type) (eqF : relation F)
                                 (v_add : operation E) (v_mult : scalar F E)
                                 (add : operation F) (mult : operation F)
                                 (v_null : E)
                                 (eps0 : F) (eps1 : F)
                                 (norm: value E) (abs : value F) := {
  vector_space_normed_field_valued :> Field_Valued F eqF add mult eps0 eps1 abs ;
  vector_space_normed_vector_space :> Vector_Space E eqE F eqF v_add v_mult add mult v_null eps0 eps1 ;
  vector_space_normed_separation : forall v : E, (norm v) = 0 -> eqE v v_null ;
  vector_space_normed_triangular_inequality : forall v w : E, norm (v_add v w) <= (norm v) + (norm w) ;
  vector_space_normed_homogeneity : forall x : F, forall v : E, norm (v_mult x v) = (abs x) * (norm v)
}.

Close Scope R_scope.

(* Can be improved
Hint Resolve
  @monoid_setoid
  @monoid_assoc
: typeclass.

Hint Rewrite
  @monoid_iden_l
  @monoid_iden_r
  @monoid_eq_compat_l
  @monoid_eq_compat_r
  @op_assoc
  @op_comm
: typeclass.*)


Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.

Require Import ExtLib.Data.ListNth.

Require Import Helix.Tactics.HelixTactics.

Import ListNotations.

Fixpoint fold_left_rev
         {A B : Type}
         (f : A -> B -> A) (a : A) (l : list B)
  : A
  := match l with
     | List.nil => a
     | List.cons b l => f (fold_left_rev f a l) b
     end.

Program Fixpoint Lbuild {A: Type}
        (n : nat)
        (gen : forall i, i < n -> A) {struct n}: list A :=
  match n with
  | O => List.nil
  | S p =>
    let gen' := fun i ip => gen (S i) _ in
    List.cons (gen 0 _) (@Lbuild A p gen')
  end.
Next Obligation. apply lt_n_S, ip. Qed.
Next Obligation. apply Nat.lt_0_succ. Qed.

Lemma nth_error_Sn {A:Type} (x:A) (xs:list A) (n:nat):
  nth_error (x::xs) (S n) = nth_error xs n.
Proof.
  reflexivity.
Qed.

Lemma rev_nil (A:Type) (x:list A):
  rev x = nil -> x = nil.
Proof.
  intros H.
  destruct x.
  -
    reflexivity.
  -
    simpl in H.
    symmetry in H.
    contradict H.
    apply app_cons_not_nil.
Qed.

(* List elements unique wrt projection [p] using [eq] *)
Definition list_uniq {A B:Type} (p: A -> B) (l:list A): Prop
  := forall x y a b,
    List.nth_error l x = Some a ->
    List.nth_error l y = Some b ->
    (p a) = (p b) -> x=y.

Lemma list_uniq_nil {A B:Type} (p: A -> B):
  list_uniq p (@nil A).
Proof.
  unfold list_uniq.
  intros x y a b H H0 H1.
  rewrite nth_error_nil in H.
  inversion H.
Qed.

Lemma list_uniq_de_cons {A B:Type} (p: A -> B) (a:A) (l:list A):
  list_uniq p (a :: l) ->
  list_uniq p l.
Proof.
  intros H.
  unfold list_uniq in *.
  intros x y a0 b H0 H1 H2.
  cut (S x = S y). auto.
  eapply H; eauto.
Qed.

Lemma list_uniq_cons {A B:Type} (p: A -> B) (a:A) (l:list A):
  list_uniq p l /\
  not (exists j x, nth_error l j = Some x /\ p x = p a) <->
  list_uniq p (a :: l).
Proof.
  split.
  -
    intros [U E].
    unfold list_uniq in *.
    intros x y a0 b H H0 H1.
    destruct x,y; cbn in *.
    +
      reflexivity.
    +
      inversion H; subst.
      contradict E.
      exists y, b.
      auto.
    +
      inversion H0; subst.
      contradict E.
      exists x, a0.
      auto.
    +
      apply eq_S.
      eapply U; eauto.
  -
    intros H.
    split ; [eapply list_uniq_de_cons; eauto|].

    intros C.
    destruct C as (j & x & C0 & C1).
    unfold list_uniq in H.
    specialize (H 0 (S j)).
    cbn in H.
    specialize (H a x).
    cut(0 = S j). intros. inv H0.
    apply H; auto.
Qed.

Lemma app_nth_error2 :
  forall {A: Type} (l:list A) l' n, n >= List.length l -> nth_error (l++l') n = nth_error l' (n-length l).
Proof.
  induction l; intros l' d [|n]; auto;
    cbn; rewrite IHl; auto with arith.
Qed.

Lemma app_nth_error1 :
  forall {A:Type} (l:list A) l' n, n < length l -> nth_error (l++l') n = nth_error l n.
Proof.
  induction l.
  - inversion 1.
  - intros l' n H.
    cbn.
    destruct n; [reflexivity|].
    rewrite 2!nth_error_Sn.
    apply IHl.
    cbn in H.
    auto with arith.
Qed.

Lemma rev_nth_error : forall {A:Type} (l:list A) n,
    (n < List.length l)%nat ->
    nth_error (rev l) n = nth_error l (List.length l - S n) .
Proof.
  induction l.
  intros; inversion H.
  intros.
  simpl in H.
  simpl (rev (a :: l)).
  simpl (List.length (a :: l) - S n).
  inversion H.
  rewrite <- minus_n_n; simpl.
  rewrite <- rev_length.
  rewrite app_nth_error2; auto.
  rewrite <- minus_n_n; auto.
  rewrite app_nth_error1; auto.
  rewrite (minus_plus_simpl_l_reverse (length l) n 1).
  replace (1 + length l) with (S (length l)); auto with arith.
  rewrite <- minus_Sn_m; auto with arith.
  apply IHl ; auto with arith.
  rewrite rev_length; auto.
Qed.

Lemma fold_left_rev_def {A B : Type} (l : list B) (e : A) (f : A -> B -> A) :
  fold_left_rev f e l = fold_left f (rev l) e.
Proof.
  induction l.
  -
    reflexivity.
  -
    cbn.
    rewrite fold_left_app, IHl.
    reflexivity.
Qed.

Lemma fold_left_fold_left_rev
      {A : Type}
      (l : list A)
      (e : A)
      (f : A -> A -> A)
      (f_commut : forall x y, f x y = f y x)
      (f_assoc : forall x y z, f x (f y z) = f (f x y) z)
  :
    fold_left_rev f e l = fold_left f l e.
Proof.
  rewrite fold_left_rev_def.
  rewrite <-fold_left_rev_right.
  rewrite rev_involutive.
  induction l; [reflexivity |].
  cbn.
  rewrite_clear IHl.
  generalize dependent a.
  induction l; [reflexivity |].
  cbn.
  congruence.
Qed.

Lemma fold_left_preservation
      {A : Type}
      (f : A -> A -> A)
      (init : A)
      (l : list A)
      (P : A -> Prop)
      (PP : forall a b, P a \/ P b -> P (f a b))
  :
    (P init \/ exists a, P a /\ In a l) ->
    P (fold_left f l init).
Proof.
  intros.
  generalize dependent init.
  induction l.
  -
    intros.
    intuition.
    destruct H0.
    intuition.
  -
    intros.
    cbn.
    apply IHl.
    destruct H as [I | [a' [Pa' La']]]; auto.
    inversion La'.
    subst; auto.
    right.
    exists a'.
    auto.
Qed.

Lemma fold_left_emergence

      {A : Type}
      (f : A -> A -> A)
      (init : A)
      (l : list A)
      (P : A -> Prop)
      (PE : forall a b, P (f a b) -> P a \/ P b)
  :
    P (fold_left f l init) ->
    (P init \/ exists a, P a /\ In a l).
Proof.
  intros.
  generalize dependent init.
  induction l.
  -
    intros.
    intuition.
  -
    intros.
    cbn in H.
    apply IHl in H.
    destruct H as [I | [a' [Pa' La']]].
    +
      apply PE in I.
      destruct I; auto.
      right.
      exists a.
      cbn.
      auto.
    +
      right.
      exists a'.
      cbn.
      auto.
Qed.

Lemma fold_left_invariant
      {A : Type}
      (f : A -> A -> A)
      (init : A)
      (l : list A)
      (P : A -> Prop)
      (PI : forall a b, P (f a b) <-> P a \/ P b)
  :
    P (fold_left f l init) <-> (P init \/ exists a, P a /\ In a l).
Proof.
  split; intros.
  -
    apply fold_left_emergence with (f0:=f).
    apply PI.
    assumption.
  -
    apply fold_left_preservation with (f0:=f).
    apply PI.
    assumption.
Qed.


Require Import Iterates F_alpha E0.
Require Import ArithRing Lia   Max.
Import Exp2 Canon.
Require Import Mult.
Open Scope nat_scope.

Section S1.
  Hypothesis H : forall (alpha beta:E0), alpha o<= beta ->
                                         forall i,  2 <= i ->
                                                    F_ alpha i <= F_ beta i.

  Remark R1 : 3 o<= E0omega.
  rewrite Le_iff; repeat split; left; reflexivity.
  Qed.

  Remark R2 : 2 <= 2.
  Proof (le_n 2).

 Let instance_H := H (E0fin 3) E0omega R1 _ R2.

  Remark R3 : F_ E0omega 2 = F_ 2 2.
  Proof.
    rewrite F_lim_eqn.
    - unfold Canon, CanonS; cbn; f_equal.
         apply E0_eq_intro; reflexivity.
    -  reflexivity.
  Qed.

  Remark R4 : F_ 3 2 = F_ 2 (F_ 2 (F_ 2 2)).
  Proof.
    ochange (E0fin 3) (E0succ 2).
    rewrite F_succ_eqn.
    do 3 rewrite iterate_S_eqn.
    reflexivity.
  Qed.

  Remark R6 : forall i, i < F_ 2 i.
  apply F_alpha_gt.
 Qed.

  Lemma Fake_thm : False.
    assert( F_ E0omega 2 < F_ 3 2). {
      rewrite R3, R4.
      generalize (R6 (F_ 2 2)); intro.
      generalize (R6 (F_ 2 (F_ 2 2))); intro.
      lia.
    }
    lia.
  Qed.

End S1.


(*
  There are two kinds of sets:
  - Sets with positive extension ("low"), which correspond to the
    usual understanding of sets as collections of
    given sets.
  - Sets with negative extension ("high"), which correspond to the
    complement of positive sets, i.e. they include all but
    the sets in a given collection.

  This model is inspired by the standard formalisation of
  ZF set theory in Coq. Visit https://github.com/coq-contribs/zfc.
*)
Inductive set :=
  | Pos : forall {X}, (X -> set) -> set
  | Neg : forall {X}, (X -> set) -> set
.
Notation 𝓥 := set.

(* Set equality *)
Fixpoint eeq a b := match a,b with
  | Pos _, Neg _ => False
  | Neg _, Pos _ => False
  | Pos f, Pos g =>
      (forall x, exists y, eeq (f x) (g y)) /\ (forall y, exists x, eeq (f x) (g y))
  | Neg f, Neg g =>
      (forall x, exists y, eeq (f x) (g y)) /\ (forall y, exists x, eeq (f x) (g y))
end.
Notation "A ≡ B" := (eeq A B) (at level 85).

(* Set membership *)
Definition iin a b := match b with
  | Pos f => exists x, eeq (f x) a
  | Neg f => forall x, eeq (f x) a -> False
end.
Notation "A ∈ B" := (iin A B) (at level 85).

(* Equality is an equivalence relation *)

Lemma eeq_refl : forall {x}, x ≡ x.
Proof. induction x; split; intro x; exists x; apply H. Qed.

Lemma eeq_trans : forall {x y z}, x ≡ y -> y ≡ z -> x ≡ z.
Proof.
  induction x; induction y; induction z; intros; simpl eeq.
  - simpl eeq in H2, H3. destruct H2, H3. split; intro.
    destruct (H2 x). destruct (H3 x0). exists x1. apply (H _ _ _ H6 H7).
    destruct (H5 y). destruct (H4 x). exists x0. apply (H _ _ _ H7 H6).
  - simpl eeq in H3. destruct H3.
  - simpl eeq in H3. destruct H3.
  - simpl eeq in H2. destruct H2.
  - simpl eeq in H2. destruct H2.
  - simpl eeq in H2. destruct H2.
  - simpl eeq in H3. destruct H3.
  - simpl eeq in H2, H3. destruct H2, H3. split; intro.
  destruct (H2 x). destruct (H3 x0). exists x1. apply (H _ _ _ H6 H7).
  destruct (H5 y). destruct (H4 x). exists x0. apply (H _ _ _ H7 H6).
Qed.

Lemma eeq_sym : forall {x y}, x ≡ y -> y ≡ x.
Proof.
  intro x. induction x; destruct y; simpl eeq; auto.
  - intro A. destruct A. split; intro a.
    -- destruct (H1 a). exists x. apply (H _ _ H2).
    -- destruct (H0 a). exists x. apply (H _ _ H2).
  - intro A. destruct A. split; intro a.
  -- destruct (H1 a). exists x. apply (H _ _ H2).
  -- destruct (H0 a). exists x. apply (H _ _ H2).
Qed.

(* Equality is sound w.r.t. membership *)

Lemma in_sound_right:
  forall {x y}, x ≡ y -> forall z, z ∈ x -> z ∈ y.
Proof.
  destruct x; destruct y; simpl eeq; intros e z; simpl iin; simpl eeq; intros; destruct e.
  - destruct H. destruct (H0 x). exists x0. pose proof (eeq_sym H2). apply (eeq_trans H3 H).
  - destruct (H2 x). pose proof (eeq_trans H3 H0). apply (H _ H4).
Qed.

Lemma in_sound_left:
  forall {x y}, x ≡ y -> forall z, x ∈ z -> y ∈ z.
Proof.
  destruct z; simpl iin; intros.
  - destruct H0. exists x0. apply (eeq_trans H0 H).
  - apply (H0 x0). apply (eeq_trans H1 (eeq_sym H)).
Qed.

(* We call 'low' the sets having a positive extension *)
Definition low x := match x with
  | Pos _ => True
  | Neg _ => False
end.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_congruencesymmetric_1 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable axiom_nocollapse_2 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable cn_congruencereflexive_3 : (forall A B : Universe, cong_ A B A B).
Variable lemma_congruencetransitive_4 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable axiom_betweennessidentity_5 : (forall A B : Universe, ~(betS_ A B A)).
Variable lemma_inequalitysymmetric_6 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_localextension_7 : (forall A B Q : Universe, (exists X : Universe, ((A <> B /\ B <> Q) -> (betS_ A B X /\ cong_ B X B Q)))).
Variable cn_equalityreverse_8 : (forall A B : Universe, cong_ A B B A).
Variable axiom_betweennesssymmetry_9 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable cn_sumofparts_10 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable axiom_innertransitivity_11 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable axiom_5_line_12 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).
Variable lemma_doublereverse_13 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).

Theorem lemma_differenceofparts_14 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (betS_ A B C /\ betS_ Xa Xb Xc))) -> cong_ B C Xb Xc)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Morphisms.
From FloatCohorts Require Import Tactics Option Arith FloatPair.

Definition dec_e (fp : float_pair) : float_pair :=
  let '(m, e) := (FPnum fp, FPexp fp) in
  FPair (m * 2) (e - 1).

Definition inc_e (fp : float_pair) : option float_pair :=
  let '(m, e) := (FPnum fp, FPexp fp) in
  match div2_opt m with
  | Some m' => Some (FPair m' (e + 1))
  | None => None
  end.

Definition dec_e_by (fp : float_pair) (de : positive) : float_pair :=
  Pos.iter dec_e fp de.

Definition inc_e_by (fp : float_pair) (de : positive) : option float_pair :=
  Pos.iter (RingMicromega.map_option inc_e) (Some fp) de.

Definition shift_e (fp : float_pair) (de : Z) : option float_pair :=
  match de with
  | 0 => Some fp
  | Z.pos d => inc_e_by fp d
  | Z.neg d => Some (dec_e_by fp d)
  end.

Definition inc_digits_m := dec_e.
Definition dec_digits_m := inc_e.
Definition inc_digits_m_by := dec_e_by.
Definition dec_digits_m_by := inc_e_by.
Definition shift_digits_m (fp : float_pair) (ddm : Z) := shift_e fp (- ddm).
Definition set_digits_m (fp : float_pair) (dm : positive) :=
  shift_digits_m fp (Z.pos dm - Z.pos (digits_m fp)).

(** * e_equiv ****)

Definition set_e (fp : float_pair) (e : Z) : option float_pair :=
  shift_e fp (e - FPexp fp).

Lemma dec_e_equiv (fp : float_pair) :
  dec_e fp === fp.
Proof.
  destruct fp as [m e].
  cbn.
  right.
  split; [lia |].
  replace (e - (e - 1)) with 1 by lia.
  rewrite Z.pow_1_r.
  reflexivity.
Qed.

Lemma inc_e_equiv (fp : float_pair) :
  is_Some (inc_e fp) ->
  inc_e fp === Some fp.
Proof.
  intros.
  destruct fp as [m e].
  cbn in *.
  destruct div2_opt as [d|] eqn:D in H;
    inversion H; clear H.
  subst.
  rewrite D.
  constructor.
  left.
  cbn.
  split; [lia |].
  replace (e + 1 - e) with 1 by lia.
  rewrite Z.pow_1_r.
  apply div2_opt_correct in D.
  rewrite D.
  reflexivity.
Qed.

Lemma dec_e_by_equiv (fp : float_pair) (de : positive) :
  dec_e_by fp de === fp.
Proof.
  unfold dec_e_by.
  apply Pos.iter_invariant; [| reflexivity].
  intros.
  rewrite <-H.
  apply dec_e_equiv.
Qed.

Lemma inc_e_by_equiv (fp : float_pair) (de : positive) :
  is_Some (inc_e_by fp de) ->
  inc_e_by fp de === Some fp.
Proof.
  unfold inc_e_by.
  apply Pos.iter_invariant; [| reflexivity].
  intros.
  destruct x; [| inversion H0].
  unfold RingMicromega.map_option in *.
  apply inc_e_equiv in H0.
  rewrite H0.
  apply H.
  constructor.
Qed.

Lemma shift_e_equiv (fp : float_pair) (de : Z) :
  is_Some (shift_e fp de) ->
  shift_e fp de === Some fp.
Proof.
  unfold shift_e.
  intros.
  destruct de.
  - reflexivity.
  - apply inc_e_by_equiv. assumption.
  - rewrite dec_e_by_equiv. reflexivity.
Qed.

Lemma set_e_equiv (fp : float_pair) (e : Z) :
  is_Some (set_e fp e) ->
  set_e fp e === Some fp.
Proof.
  apply shift_e_equiv.
Qed.

(** * e_res ****)

Lemma inc_e_res (fp : float_pair) :
  forall fp',
    inc_e fp = Some fp' ->
    FPexp fp' = FPexp fp + 1.
Proof.
  intros.
  unfold inc_e in H.
  break_match; inversion H.
  cbn.
  reflexivity.
Qed.

Lemma dec_e_res (fp : float_pair) :
  FPexp (dec_e fp) = FPexp fp - 1.
Proof.
  reflexivity.
Qed.

Lemma inc_e_by_res (fp : float_pair) (de : positive) :
  forall fp',
    inc_e_by fp de = Some fp' ->
    FPexp fp' = FPexp fp + Z.pos de.
Proof.
  unfold inc_e_by.
  induction de using Pos.peano_ind.
  -
    apply inc_e_res.
  -
    intros.
    rewrite Pos.iter_succ in H.
    destruct (Pos.iter (RingMicromega.map_option inc_e) (Some fp) de);
      try discriminate.
    cbn in H.
    break_match; inversion H.

    assert (T : Some f = Some f) by reflexivity.
    specialize (IHde f T).
    cbn in *; lia.
Qed.

Lemma dec_e_by_res (fp : float_pair) (de : positive) :
  FPexp (dec_e_by fp de) = FPexp fp - Z.pos de.
Proof.
  unfold dec_e_by.
  induction de using Pos.peano_ind.
  -
    apply dec_e_res.
  -
    rewrite Pos.iter_succ.
    rewrite dec_e_res.
    lia.
Qed.

Lemma shift_e_res (fp : float_pair) (de : Z) :
  forall fp',
    shift_e fp de = Some fp' ->
    FPexp fp' = FPexp fp + de.
Proof.
  intros.
  destruct de; cbn in *.
  -
    inversion H.
    lia.
  -
    apply inc_e_by_res.
    assumption.
  -
    inversion H.
    rewrite dec_e_by_res.
    lia.
Qed.

Lemma set_e_res (fp : float_pair) (e : Z) :
  forall fp',
    set_e fp e = Some fp' ->
    FPexp fp' = e.
Proof.
  intros.
  unfold set_e in H.
  apply shift_e_res in H.
  lia.
Qed.

(** * e_exact ****)

Lemma dec_e_exact (fp fp' : float_pair) :
  fp' === fp ->
  FPexp fp' = FPexp fp - 1 ->
  dec_e fp = fp'.
Proof.
  intros.
  cbn.
  apply exponent_unique; [cbn; congruence |].
  rewrite H.
  apply dec_e_equiv.
Qed.

Lemma inc_e_exact (fp fp' : float_pair) :
  fp' === fp ->
  FPexp fp' = FPexp fp + 1 ->
  inc_e fp = Some fp'.
Proof.
  intros.
  cbn.
  break_match.
  +
    f_equal.
    apply exponent_unique.
    cbn; congruence.
    rewrite H.

    destruct fp as [m e].
    cbn.
    left.
    split; [lia |].
    replace (e + 1 - e) with 1 by lia.
    rewrite Z.pow_1_r.
    cbn in Heqo.
    apply div2_opt_correct in Heqo.
    congruence.
  +
    exfalso.
    cbn in H.
    destruct H; try lia.
    rewrite H0 in H.
    replace (FPexp fp + 1 - FPexp fp) with 1 in H by lia.
    cbn in H.
    destruct H.
    inversion H1.
    rewrite H3 in Heqo.
    clear - Heqo.
    rewrite Pos.mul_xO_r in Heqo.
    cbn in Heqo.
    discriminate.
Qed.

Lemma dec_e_by_exact (fp fp' : float_pair) (de : positive) :
  fp' === fp ->
  FPexp fp' = FPexp fp - Z.pos de ->
  dec_e_by fp de = fp'.
Proof.
  (* induction is not actually needed here *)
  (* this is just the fastest way to destruct [de] as [xH] or [Pos.succ] *)
  induction de using Pos.peano_ind.
  -
    apply dec_e_exact.
  -
    intros.
    unfold dec_e_by.
    rewrite Pos.iter_succ.
    apply dec_e_exact.
    rewrite H.
    symmetry.
    apply dec_e_by_equiv.
    rewrite dec_e_by_res.
    lia.
Qed.

Lemma inc_e_by_exact (fp fp' : float_pair) (de : positive) :
  fp' === fp ->
  FPexp fp' = FPexp fp + Z.pos de ->
  inc_e_by fp de = Some fp'.
Proof.
  generalize dependent fp'.
  induction de using Pos.peano_ind.
  -
    apply inc_e_exact.
  -
    intros.
    unfold inc_e_by.
    rewrite Pos.iter_succ.
    replace (Pos.iter (RingMicromega.map_option inc_e) (Some fp) de)
      with (inc_e_by fp de)
      by reflexivity.
    erewrite (IHde (dec_e fp')).
    apply inc_e_exact.
    symmetry; apply dec_e_equiv.
    rewrite dec_e_res; lia.
    rewrite <-H; apply dec_e_equiv.
    rewrite dec_e_res; lia.
Qed.

Lemma shift_e_exact (fp fp' : float_pair) (de : Z) :
  fp' === fp ->
  FPexp fp' = FPexp fp + de ->
  shift_e fp de = Some fp'.
Proof.
  destruct de.
  -
    intros.
    cbn.
    f_equal.
    apply exponent_unique.
    lia.
    symmetry; assumption.
  -
    apply inc_e_by_exact.
  -
    intros.
    cbn.
    f_equal.
    apply dec_e_by_exact; assumption.
Qed.

Lemma set_e_exact (fp fp' : float_pair) (e : Z) :
  fp' === fp ->
  FPexp fp' = e ->
  set_e fp e = Some fp'.
Proof.
  intros.
  unfold set_e.
  erewrite shift_e_exact.
  reflexivity.
  assumption.
  lia.
Qed.

Open Scope positive_scope.

(** * digits_m_equiv ****)

Lemma inc_digits_m_equiv (fp : float_pair) :
  inc_digits_m fp === fp.
Proof. apply dec_e_equiv. Qed.

Lemma dec_digits_m_equiv (fp : float_pair) :
  is_Some (dec_digits_m fp) ->
  dec_digits_m fp === Some fp.
Proof. apply inc_e_equiv. Qed.

Lemma inc_digits_m_by_equiv (fp : float_pair) (ddm : positive) :
  inc_digits_m_by fp ddm === fp.
Proof. apply dec_e_by_equiv. Qed.

Lemma dec_digits_m_by_equiv (fp : float_pair) (ddm : positive) :
  is_Some (dec_digits_m_by fp ddm) ->
  dec_digits_m_by fp ddm === Some fp.
Proof. apply inc_e_by_equiv. Qed.

Lemma shift_digits_m_equiv (fp : float_pair) (ddm : Z) :
  is_Some (shift_digits_m fp ddm) ->
  shift_digits_m fp ddm === Some fp.
Proof. apply shift_e_equiv. Qed.

Lemma set_digits_m_equiv (fp : float_pair) (dm : positive) :
  is_Some (set_digits_m fp dm) ->
  set_digits_m fp dm === Some fp.
Proof. apply shift_e_equiv. Qed.

(** * digits_m_res ****)

Lemma inc_digits_m_res (fp : float_pair) :
  digits_m (inc_digits_m fp) = digits_m fp + 1.
Proof.
  unfold inc_digits_m, dec_e.
  cbn.
  replace 2 with (2 ^ 1) by reflexivity.
  rewrite pos_size_mul_pow_two.
  reflexivity.
Qed.

Lemma dec_digits_m_res (fp : float_pair) :
  forall fp',
    dec_digits_m fp = Some fp' ->
    digits_m fp' + 1 = digits_m fp.
Proof.
  unfold dec_digits_m, inc_e.
  intros.
  break_match; inversion H.
  apply div2_opt_correct in Heqo.
  cbn.
  unfold digits_m.
  rewrite Heqo.
  replace 2 with (2 ^ 1) by reflexivity.
  rewrite pos_size_mul_pow_two.
  lia.
Qed.

Lemma inc_digits_m_by_res (fp : float_pair) (ddm : positive) :
  digits_m (inc_digits_m_by fp ddm) = digits_m fp + ddm.
Proof.
  unfold inc_digits_m_by, dec_e_by.
  fold inc_digits_m.

  induction ddm using Pos.peano_ind.
  -
    apply inc_digits_m_res.
  -
    rewrite Pos.iter_succ.
    rewrite inc_digits_m_res.
    lia.
Qed.

Lemma dec_digits_m_by_res (fp : float_pair) (ddm : positive) :
  forall fp',
    dec_digits_m_by fp ddm = Some fp' ->
    digits_m fp' + ddm = digits_m fp.
Proof.
  unfold dec_digits_m_by, inc_e_by.
  fold dec_digits_m.
  induction ddm using Pos.peano_ind.
  -
    intros.
    cbn in *.
    break_match; inversion H.
    apply div2_opt_correct in Heqo.
    unfold digits_m.
    rewrite Heqo.
    replace 2 with (2 ^ 1) by reflexivity.
    rewrite pos_size_mul_pow_two.
    cbn.
    lia.
  -
    intros.
    rewrite Pos.iter_succ in H.
    destruct (Pos.iter (RingMicromega.map_option dec_digits_m) (Some fp) ddm);
      try discriminate.
    cbn in H.
    break_match; inversion H; clear H H1.

    assert (T : Some f = Some f) by reflexivity.
    specialize (IHddm f T); clear T.
    unfold digits_m in *.
    cbn in *.
    apply div2_opt_correct in Heqo.
    rewrite Heqo in IHddm.
    replace 2 with (2 ^ 1) in IHddm by reflexivity.
    rewrite pos_size_mul_pow_two in IHddm.
    lia.
Qed.

Lemma shift_digits_m_res (fp : float_pair) (ddm : Z) :
  forall fp',
    shift_digits_m fp ddm = Some fp' ->
    Z.pos (digits_m fp') = (Z.pos (digits_m fp) + ddm)%Z.
Proof.
  intros.
  destruct ddm; cbn in *.
  -
    congruence.
  -
    fold inc_digits_m_by in H.
    inversion H.
    rewrite inc_digits_m_by_res.
    lia.
  -
    fold dec_digits_m_by in H.
    apply dec_digits_m_by_res in H.
    rewrite <-Pos2Z.add_pos_neg.
    lia.
Qed.

Lemma set_digits_m_res (fp : float_pair) (dm : positive) :
  forall fp',
    set_digits_m fp dm = Some fp' ->
    digits_m fp' = dm.
Proof.
  intros.
  apply shift_digits_m_res in H.
  lia.
Qed.

(** * digits_m_exact ****)

Lemma inc_digits_m_exact (fp fp' : float_pair) :
  fp' === fp ->
  digits_m fp' = digits_m fp + 1 ->
  inc_digits_m fp = fp'.
Proof.
  intros.
  apply digits_m_unique.
  rewrite inc_digits_m_res.
  lia.
  rewrite H.
  apply inc_digits_m_equiv.
Qed.

Lemma dec_digits_m_exact (fp fp' : float_pair) :
  fp' === fp ->
  digits_m fp' + 1 = digits_m fp ->
  dec_digits_m fp = Some fp'.
Proof.
  intros.
  unfold dec_digits_m, inc_e.
  break_match.
  -
    f_equal.
    apply digits_m_unique.
    cbn.
    apply div2_opt_correct in Heqo.
    unfold digits_m in *.
    rewrite Heqo in H0.
    replace 2 with (2 ^ 1) in H0 by reflexivity.
    rewrite pos_size_mul_pow_two in H0.
    lia.

    rewrite H; clear H H0.
    destruct fp as [m e].
    cbn.
    left.
    split; [lia |].
    replace (e + 1 - e)%Z with 1%Z by lia.
    rewrite Z.pow_1_r.
    cbn in Heqo.
    apply div2_opt_correct in Heqo.
    congruence.
  -
    symmetry in H0.
    apply inc_digits_m_exact in H0; [| symmetry; assumption].
    unfold inc_digits_m in H0.
    destruct fp as (m, e).
    cbn in H0, Heqo.
    inversion H0; subst.
    unfold div2_opt in Heqo.
    rewrite Pos.mul_xO_r in Heqo.
    discriminate.
Qed.

Lemma inc_digits_m_by_exact (fp fp' : float_pair) (ddm : positive) :
  fp' === fp ->
  digits_m fp' = digits_m fp + ddm ->
  inc_digits_m_by fp ddm = fp'.
Proof.
  induction ddm using Pos.peano_ind.
  -
    apply inc_digits_m_exact.
  -
    intros.
    unfold inc_digits_m_by, dec_e_by.
    rewrite Pos.iter_succ.
    fold inc_digits_m.
    apply inc_digits_m_exact.
    rewrite H.
    symmetry.
    apply inc_digits_m_by_equiv.
    rewrite inc_digits_m_by_res.
    lia.
Qed.

Lemma dec_digits_m_by_exact (fp fp' : float_pair) (ddm : positive) :
  fp' === fp ->
  digits_m fp' + ddm = digits_m fp ->
  dec_digits_m_by fp ddm = Some fp'.
Proof.
  generalize dependent fp'.
  induction ddm using Pos.peano_ind.
  -
    apply dec_digits_m_exact.
  -
    intros.
    unfold dec_digits_m_by, inc_e_by.
    rewrite Pos.iter_succ.
    replace (Pos.iter (RingMicromega.map_option inc_e) (Some fp) ddm)
      with (dec_digits_m_by fp ddm)
      by reflexivity.
    erewrite (IHddm (inc_digits_m fp')).
    apply dec_digits_m_exact.
    symmetry; apply inc_digits_m_equiv.
    rewrite inc_digits_m_res; lia.
    rewrite <-H; apply inc_digits_m_equiv.
    rewrite inc_digits_m_res; lia.
Qed.

Lemma shift_digits_m_exact (fp fp' : float_pair) (ddm : Z) :
  fp' === fp ->
  (Z.pos (digits_m fp') = Z.pos (digits_m fp) + ddm)%Z ->
  shift_digits_m fp ddm = Some fp'.
Proof.
  intros.
  destruct ddm.
  -
    cbn.
    f_equal.
    apply digits_m_unique.
    lia.
    symmetry; assumption.
  -
    cbn.
    f_equal.
    apply inc_digits_m_by_exact.
    assumption.
    lia.
  -
    apply dec_digits_m_by_exact.
    assumption.
    lia.
Qed.

Lemma set_digits_m_exact (fp fp' : float_pair) (dm : positive) :
  fp' === fp ->
  digits_m fp' = dm ->
  set_digits_m fp dm = Some fp'.
Proof.
  intros.
  apply shift_digits_m_exact.
  assumption.
  lia.
Qed.

(** * spec *)

Theorem set_e_spec (fp fp' : float_pair) (e : Z) :
  set_e fp e = Some fp'
  <->
  fp' === fp /\ FPexp fp' = e.
Proof.
  split; intros.
  -
    split.
    +
      enough (T : Some fp' === Some fp) by (inversion T; assumption).
      rewrite <-H.
      apply set_e_equiv; rewrite H; constructor.
    +
      eapply set_e_res; eassumption.
  -
    apply set_e_exact; intuition.
Qed.

Corollary set_e_None_inv (fp : float_pair) (e : Z) :
  set_e fp e = None
  ->
  forall fp', fp' === fp -> (FPexp fp' < e)%Z.
Proof.
  intros.
  apply Z.nle_gt.
  intros C.
  destruct (Z.eq_dec e (FPexp fp')).
  -
    enough (set_e fp e = Some fp') by congruence.
    apply set_e_spec; intuition.
  -
    assert (H1 : (e < FPexp fp')%Z) by lia; clear C n.
    destruct (set_e fp' e) as [fp''|] eqn:H2.
    +
      apply set_e_spec in H2.
      enough (set_e fp e = Some fp'') by congruence.
      apply set_e_spec.
      intuition.
      rewrite H3; assumption.
    +
      unfold set_e, shift_e in H2.
      break_match; try discriminate.
      lia.
Qed.

Theorem set_digits_m_spec (fp fp' : float_pair) (dm : positive) :
  set_digits_m fp dm = Some fp'
  <->
  fp' === fp /\ digits_m fp' = dm.
Proof.
  split; intros.
  -
    split.
    +
      enough (T : Some fp' === Some fp) by (inversion T; assumption).
      rewrite <-H.
      apply set_digits_m_equiv; rewrite H; constructor.
    +
      eapply set_digits_m_res; eassumption.
  -
    apply set_digits_m_exact; intuition.
Qed.

Corollary set_digits_m_None_inv (fp : float_pair) (dm : positive) :
  set_digits_m fp dm = None
  ->
  forall fp', fp' === fp -> dm < digits_m fp'.
Proof.
  intros.
  apply Pos.lt_nle.
  intros C.
  destruct (Pos.eq_dec dm (digits_m fp')).
  -
    enough (set_digits_m fp dm = Some fp') by congruence.
    apply set_digits_m_spec; intuition.
  -
    assert (H1 : digits_m fp' < dm) by lia; clear C n.
    destruct (set_digits_m fp' dm) as [fp''|] eqn:H2.
    +
      apply set_digits_m_spec in H2.
      enough (set_digits_m fp dm = Some fp'') by congruence.
      apply set_digits_m_spec.
      intuition.
      rewrite H3; assumption.
    +
      unfold set_digits_m, shift_digits_m, shift_e in H2.
      break_match; try discriminate.
      lia.
Qed.