(** Definition of the ordered setoid of ordinal numbers, together with
    proofs that it is indeed an ordered setoid under the given relations.
    That is:
    - Ord.eq (==) is an equivalence relation;
    - Ord.lt (<) is an ==-compatible strict ordering relation;
    - Ord.le (≤) is a partial ordering relation w.r.t. ==;
    - < is a subrelation of ≤.

    Some desirable properties (such as totality) require excluded middle,
    and are deferred to the OrdClassical module.

    Implementation note:
    A rather more elegant mutually recursive definition of < and ≤ is
    possible, and was originally to be used here:
    - ssup f ≤ y when, for all a:A, f(a) < y;
    - x < ssup g when, for some b:B, x ≤ g(b).
      However, Coq does not accept these as fixpoint definitions since
    they descend on different parameters. It does accept them as
    inductive definitions, but this would require them to be redefined
    inside the Ord module, which causes annoying notational issues.
    We have instead included proofs of the above properties for our
    definitions, as lemmata le_lt and lt_le respectively.
*)

From Ordinal Require Import CommonHeader WellOrderClass Notations.

Require Arith_base.

Generalizable All Variables.

Open Scope Ord_scope.

(** An ordinal is represented by the image of a (possibly empty) function
    with codomain the ordinals. Conceptually it 'is' the least ordinal
    greater than every element of the function's range. *)

Inductive Ord := Ord_ssup `(x: A → Ord).

Module Ord <: EqLtLe' <: StrOrder.

  Definition t := Ord.
  Notation ssup := Ord_ssup.

  Definition src (o: Ord) := let (A, _) := o in A.

  Definition src_map (o: Ord) : src o → Ord :=
    match o with ssup f => f end.

  Fixpoint le o o': Prop :=
    ∀ a: src o, ∃ a': src o',le (src_map o a) (src_map o' a').

  Fixpoint lt o o': Prop :=
    ∃ a': src o', ∀ a: src o, lt (src_map o a) (src_map o' a').

  Definition ge := flip le.
  Definition gt := flip lt.
  Definition eq := relation_conjunction le ge.

  #[export] Hint Unfold ge gt relation_conjunction flip: core.

  Include EqLtLeNotation.
  Infix "≤" := le.
  Infix "≥" := ge.
  Notation "x =/= y" := (x ~= y).

  Section Reduction_Lemmata.

    Lemma le_le `(x: A → Ord) `(y: B → Ord):
      (∀ a, ∃ b, x a ≤ y b) ↔ ssup x ≤ ssup y.
    Proof. reflexivity. Qed.

    Lemma lt_lt `(x: A → Ord) `(y: B → Ord):
      (∃ b, ∀ a, x a < y b) ↔ ssup x < ssup y.
    Proof. reflexivity. Qed.

    Fixpoint le_lt (o: Ord): ∀ [A] (x: A → Ord), (∀ a, x a < o) ↔ ssup x ≤ o.
    Proof.
      destruct o as [A' x'].
      split.
      intros hyp a; specialize (hyp a).
      simpl in a, hyp |- *. destruct (x a).
      destruct hyp as [a' hyp]. exists a'.
      apply le_lt. auto.
    Qed.

    Fixpoint lt_le (o: Ord): ∀ [A] (x: A → Ord), (∃ a, o ≤ x a) ↔ o < ssup x.
    Proof.
      destruct o as [A' x'].
      split.
      intros [a hyp]. exists a.
      simpl in hyp |- *. destruct (x a).
      intro. apply lt_le, hyp.
    Qed.

    Lemma eq_le `(x: A → Ord) `(y: B → Ord):
      (∀ a, ∃ b, x a ≤ y b) → (∀ b, ∃ a, y b ≤ x a) → (ssup x == ssup y)%Ω.
    Proof @conj _ _.

    Lemma eq_eq `(x: A → Ord) `(y: B → Ord):
      (∀ a, ∃ b, x a == y b) → (∀ b, ∃ a, y b == x a) → (ssup x == ssup y)%Ω.
    Proof. firstorder. Qed.

  End Reduction_Lemmata.

  Section Order_Properties.

    Open Scope equiv_scope.

    #[export] Instance lt_sub_le: subrelation lt le.
    Proof.
      unfold subrelation; fix Fix 1.
      destruct x, y, 1; eexists; eauto.
    Qed.

    #[export] Instance eq_sub_le: subrelation eq le.
    Proof λ x y H, proj1 H.

    #[export] Instance le_preorder: PreOrder le.
    Proof.
      split; autounfold.
      fix Fix 1.
      - destruct x; intro a; now exists a.
      - destruct x, y, z; intros H1 H2 a.
        edestruct H1, H2. eauto.
    Qed.

    #[export] Instance ge_preorder: PreOrder ge | 2 :=
      flip_PreOrder _.

    #[export] Instance lt_strorder: StrictOrder lt.
    Proof.
      split; autounfold.
      fix Fix 1.
      - destruct x, 1; firstorder.
      - destruct x, y, z, 1, 1.
        eexists; eauto.
    Qed.

    #[export] Instance gt_strorder: StrictOrder gt | 2 :=
      flip_StrictOrder _.

    #[export] Instance eq_equiv: Equivalence eq.
    Proof.
      firstorder using le_preorder.
    Qed.

    #[export] Instance le_partial_order: PartialOrder eq le.
    Proof.
      now_show (eq === relation_conjunction le (flip le)).
      reflexivity.
    Qed.

    #[export] Instance ge_partial_order: PartialOrder eq ge | 2 :=
      PartialOrder_inverse _.

    #[export] Instance lt_le_compat: Proper (le --> le ++> impl) lt.
    Proof.
      autounfold. fix Fix 1.
      intros [A x] [B y] Le [A' x'] [B' y'] Le'.
      unfold flip; simpl in *.
      intros (a', Lt). specialize (Le' a') as (b', Le').
      exists b'. intro b. specialize (Le b) as (a, Le).
      specialize (Lt a).
      eapply Fix; eassumption.
    Qed.

    #[export] Instance lt_compat: Proper (eq ==> eq ==> iff) lt.
    Proof.
      apply (proper_sym_impl_iff_2 _ _).
      firstorder using lt_le_compat.
    Qed.

    #[export] Instance lt_wf: well_founded lt.
    Proof.
      intro x. enough (∀ (y: Ord) (H: y ≤ x), Acc lt y).
      { apply H; reflexivity. }
      induction x as [A f IH], y as [B g].
      intro; constructor; intros z H'.
      apply lt_le in H'. destruct H' as [b H'].
      specialize (H b) as [a H].
      apply (IH a). etransitivity; eassumption.
    Qed.

    #[export] Instance lt_ext: Extensional eq lt.
    Proof.
      enough (WeaklyExtensional eq lt) by exact _.
      intros x y H; split.
      induction x as [A f IH], y as [B g]. simpl.
      intro x. apply lt_le, H, le_lt; reflexivity.
    Qed.

    #[export] Instance lt_wo: WellOrder eq lt := { }.

    #[export] Instance pointwise_eq_sub_le [A]:
    subrelation (pointwise_relation A eq) (pointwise_relation A le) := _.

    #[export] Instance pointwise_lt_sub_le [A]:
    subrelation (pointwise_relation A lt) (pointwise_relation A le) := _.

    #[export] Instance unary_covariant_is_proper (op: Ord → Ord):
      Proper (le ==> le) op → Proper (eq ==> eq) op.
    Proof. firstorder. Qed.

    #[export] Instance binop_covariant_proper (op: Ord → Ord → Ord):
      Proper (le ==> le ==> le) op → Proper (eq ==> eq ==> eq) op.
    Proof. firstorder. Qed.

    #[export] Instance pointwise_covariant_is_proper [A] (op: (A → Ord) → Ord):
      Proper (pointwise_relation A le ==> le) op →
      Proper (pointwise_relation A eq ==> eq) op.
    Proof.
      intros covariant x y E. pose proof (E' := symmetry E).
      apply pointwise_eq_sub_le in E, E'.
      split; auto.
    Qed.

  End Order_Properties.

  Section Strict_Supremum.

    Variable A: Type.

    #[export]
    Instance ssup_covariance: Proper (pointwise_relation A le ++> le) ssup.
    Proof. firstorder. Qed.

    #[export]
    Instance ssup_compat: Proper (pointwise_relation A eq ==> eq) ssup := _.

    Property ssup_gt (x: A → Ord): ∀ a, x a < ssup x.
    Proof.
      apply le_lt; reflexivity.
    Qed.

    Property ssup_minimality (x: A → Ord): ∀ s, (∀ a: A, x a < s) ↔ ssup x ≤ s.
    Proof.
      intro; apply le_lt.
    Qed.

    Property ssup_ge (x: A → Ord): ∀ a, x a ≤ ssup x.
    Proof.
      intro; apply lt_sub_le, ssup_gt.
    Qed.

    Lemma compose_le `(x: B → Ord) (f: A → B): ssup (x ∘ f) ≤ ssup x.
    Proof.
      intro a; exists (f a). reflexivity.
    Qed.

  End Strict_Supremum.

  Section Propriety.

    Variable Q: ∀ A, (A → Ord) → Prop.
    Let P (o: Ord) := Q (src_map o).

    Hypothesis proper: Proper (eq ==> iff) P.

    #[export]
    Instance proper_is_pointwise_proper A:
      Proper (pointwise_relation A eq ==> iff) (@Q A).
    Proof.
      intros x y H.
      now apply ssup_compat, proper in H.
    Qed.

    Theorem source_irrelevance (o: Ord):
      ∀ A (f: A → Ord), ssup f == o → Q f → P o.
    Proof.
      intros A f Eq. now rewrite <- Eq.
    Qed.

    Theorem source_irrelevance_inv (o: Ord):
      P o → ∀ A (f: A → Ord), ssup f == o → Q f.
    Proof.
      intros H A f Eq. now rewrite <- Eq in H.
    Qed.

  End Propriety.

  Section Zero.

    Definition zero: Ord := ssup (Empty_set_rect _).

    Property zero_le: ∀ x: Ord, zero ≤ x.
    Proof λ x, Empty_set_ind _.

    Definition zero_unique z: (∀ x, z ≤ x) -> z == zero.
    Proof λ h, conj (h zero) (zero_le z).

    Property le_zero_is_zero x: x ≤ zero -> x == zero.
    Proof λ h, conj h (zero_le x).

    Property nlt_zero: ∀ w, ¬(w  < zero).
    Proof.
      intros [] []; contradiction.
    Qed.

    Definition lt_zero_exfalso {P: Ord -> Type} w: w < zero → P w :=
      λ h, False_rect (P w) (nlt_zero w h).

    Property ssup_empty_is_zero w: ¬inhabited (src w) ↔ w == zero.
    Proof.
      destruct w as (A, x); simpl. split.
      - intro N. apply le_zero_is_zero, le_lt.
        intro a; now contradict N.
      - intros [H _] [a]. now destruct (H a).
    Qed.

    Property ssup_inhabited_is_positive w: inhabited (src w) ↔ w > zero.
    Proof.
      split; intros [a].
      - exists a; intros [].
      - auto.
    Qed.

    Property ssup_nonempty_is_nonzero w: ¬¬inhabited (src w) ↔ w ~= zero.
    Proof.
      split. intros H H'.
      apply (ssup_empty_is_zero w) in H'.
      contradiction.
    Qed.

  End Zero.

  #[export] Hint Resolve zero_le: ord.
  #[export] Hint Resolve zero_unique: ord.
  #[export] Hint Resolve le_zero_is_zero: ord.
  #[export] Hint Resolve nlt_zero: ord.
  #[export] Hint Resolve <- ssup_empty_is_zero: ord.
  #[export] Hint Resolve <- ssup_inhabited_is_positive: ord.
  #[export] Hint Resolve <- ssup_nonempty_is_nonzero: ord.

  Section Successor.
    (** The successor operation and its basic properties. *)

    Definition succ (o: Ord): Ord := ssup (λ _:unit, o).

    #[export]
    Instance succ_strict_covariance: Proper (lt ++> lt) succ.
    Proof.
      repeat intro; simpl; repeat elim_quantifiers.
      assumption.
    Qed.

    #[export]
    Instance succ_covariance: Proper (le ==> le) succ.
    Proof.
      unfold succ; solve_proper.
    Qed.

    #[export]
    Instance succ_compat: Proper (eq ==> eq) succ := _.

    Property succ_gt o: o < succ o.
    Proof.
      apply -> lt_le. exists tt; reflexivity.
    Qed.

    Property succ_minimality o: ∀ s, o < s ↔ succ o ≤ s.
    Proof.
      split; intros.
      - apply -> le_lt; auto.
      - apply <- le_lt in H; auto using tt.
    Qed.

    Property succ_ge o: o ≤ succ o.
    Proof.
      apply lt_sub_le, succ_gt.
    Qed.

    Property le_iff_lt_succ x y: x ≤ y ↔ x < succ y.
    Proof.
      intros; split; intro H.
      - apply -> lt_le; repeat constructor; assumption.
      - apply <- lt_le in H; destruct H; assumption.
    Qed.

    Property succ_lt_inv x y: succ x < succ y → x < y.
    Proof.
      intros; now apply succ_minimality, le_iff_lt_succ.
    Qed.

    Property succ_le_inv: ∀ x y, succ x ≤ succ y → x ≤ y.
    Proof.
      intros; now apply le_iff_lt_succ, succ_minimality.
    Qed.

    Property succ_inj: ∀ x y, succ x == succ y → x == y.
    Proof.
      destruct 1; split; now apply succ_le_inv.
    Qed.

  End Successor.

  #[export] Hint Resolve -> succ_minimality: ord.
  #[export] Hint Rewrite <- succ_gt: ord.
  #[export] Hint Rewrite <- succ_minimality: ord.

  Section Limit_and_Successor_Ordinals.

    Definition Is_successor (o: Ord) := ∃ p, succ p == o.

    Definition Is_limit (o: Ord) := ∀ p, p < o → succ p < o.

    #[export]
    Instance: Proper (eq ==> iff) Is_successor.
    Proof.
      unfold Is_successor; solve_proper.
    Qed.

    #[export]
    Instance: Proper (eq ==> iff) Is_limit.
    Proof.
      unfold Is_limit; solve_proper.
    Qed.

    (** Constructively we cannot prove every ordinal is either a
     successor or a limit ordinal, but we can prove the following. *)

    Fact limit_nand_successor (o: Ord): ¬(Is_limit o ∧ Is_successor o).
    Proof.
      intros [H [p H']]. rewrite <- H' in H. clear dependent o.
      pose proof (H'' := succ_gt p).
      specialize (H p H''). contradict H. apply irreflexivity.
    Qed.

    Fact not_successor_is_limit (o: Ord) : ¬Is_successor o → Is_limit o.
    Proof.
      intros H p L.
      assert (Hp: succ p =/= o) by firstorder.
      give_up.
    Abort.
    (* Is this even true constructively? *)

    (** An ordinal is a successor iff every map into the ordinals
    specifying it has a maximal element, iff any map does so. *)

    Lemma successor_max (o: Ord):
      Is_successor o →
      ∀ `(x: A → Ord), ssup x == o → ∃ μ: A, ∀ a: A, x μ ≥ x a.
    Proof.
      intros [o' s] I x Eq.
      rewrite <- Eq in s; clear dependent o.
      specialize (proj1 s tt) as [i s1];
      specialize (proj2 s i) as [[] s2];
      pose proof (Eq' := conj s1 s2: o' == x i); clear s1 s2.
      rewrite -> Eq' in s.
      exists i. firstorder.
    Qed.

    Lemma max_successor (o: Ord) `(x: A → Ord) (Eq: ssup x == o):
      (∃ μ: A, ∀ a: A, x μ ≥ x a) → Is_successor o.
    Proof.
      intros [μ M]. exists (x μ).
      rewrite <- Eq; clear dependent o.
      split.
      - intros []; exists μ; reflexivity.
      - intro a; exists tt; apply M.
    Qed.

  End Limit_and_Successor_Ordinals.

  Section From_WF.
    (** Mapping of other sets with well-founded relations into the ordinals *)

    Context `{Rwf: well_founded A R}.
    Local Infix "≺" := R (at level 70).

    Let fwf (a: A) (ih: ∀ x: A, x ≺ a → Ord): Ord :=
        @ssup {y | y ≺ a} (sig_apply ih).

    Definition from_wf := Fix _ fwf : A → Ord.

    Local Lemma fwf_ext (a: A) (f g: ∀ y, y ≺ a → Ord) :
      (∀ (y:A) (p: y ≺ a), f y p == g y p) -> fwf f == fwf g.
    Proof.
      intro H. apply eq_eq.
      intro y; exists y. destruct y.
      2: symmetry.
      apply H.
    Qed.

    Local Lemma fwf_inv (x: A):
      ∀ (r s: Acc R x), Fix_F _ fwf r == Fix_F _ fwf s.
    Proof.
      induction (Rwf x); intros.
      rewrite <-! Fix_F_eq.
      apply fwf_ext.
      auto.
    Qed.

    Property from_wf_eq a:
      from_wf a == ssup (λ y: {y | y ≺ a}, from_wf (proj1_sig y)).
    Proof.
      change (ssup _) with (fwf (λ y (_: y ≺ a), from_wf y)).
      unfold from_wf, Fix. rewrite <- Fix_F_eq.
      apply fwf_ext. intros. apply fwf_inv.
    Qed.

    Global Instance from_wf_strict_covariance: Proper (R ==> lt) from_wf.
    Proof.
      intros x y p. rewrite -> (from_wf_eq y).
      exact (ssup_gt _ (exist _ x p)).
    Qed.

    Context `{equivA: Equivalence A eqA}.
    Context {R_compat: Proper (eqA ==> eqA ==> iff) R}.
    Local Infix "≃" := eqA (at level 70).

    Global Instance from_wf_compat: Proper (eqA ==> eq) from_wf.
    Proof.
      intros x y e. rewrite ->! from_wf_eq.
      apply eq_eq.
      intros [z r].
      pose (r' := r).
      apply (R_compat (reflexivity z) e) in r'.
      exists (exist _ z r'). reflexivity.
    Qed.

    Context {Rtrans: Transitive R}.

    Local Coercion sig_of_sig2 : sig2 >-> sig.

    Property lt_from_wf (x: Ord) (a: A): x < from_wf a → ∃ a': A, x == from_wf a'.
    Proof.
    Abort.

    Context {Rwext: WeaklyExtensional eqA R}.

    Property from_wf_inj: ∀ x y, from_wf x == from_wf y → x ≃ y.
    Proof.
      induction y as [y IH] using well_founded_ind. intro Eq.
      apply weak_extensionality. intro t; split.
    Abort.

  End From_WF.

  Section From_Nat.
    (** Mapping of the natural numbers into the finite ordinals. We could
    just use from_wf, but we instead define a simpler function and then
    show that it is equivalent. *)

    Fixpoint from_nat (n: nat): Ord :=
      match n with
      | 0 => zero
      | S n' => succ (from_nat n')
      end.

    Local Lemma from_wf_nat_covariance:
      Proper (Peano.le ==> le) (from_wf (R := Peano.lt)).
    Proof.
      intros m n h.
      apply Arith.Compare_dec.le_lt_eq_dec in h; destruct h.
      - apply lt_sub_le, from_wf_strict_covariance. assumption.
      - destruct e. reflexivity.
    Qed.

    Proposition from_wf_is_from_nat:
      pointwise_relation _ eq (from_wf (R := Peano.lt)) from_nat.
    Proof.
      intro n; induction n.
      cbn [from_nat]. rewrite -> from_wf_eq.
      - apply ssup_empty_is_zero. firstorder with arith.
      - rewrite <- IHn; clear IHn. split.
        + simpl. intros [m l]; exists tt.
          apply from_wf_nat_covariance; auto with arith.
        + intro. assert (l: (n < S n)%nat) by auto.
          now exists (exist _ n l).
    Qed.
    (*
    Lemma from_nat_src (n: nat): (0 < n)%nat → unit = src (from_nat n) :> Type.
    Proof.
      intro H. rewrite <- (Arith.PeanoNat.Nat.succ_pred_pos _ H). reflexivity.
    Qed.

    Lemma from_nat_src_0 (n: nat): ∅ = src (from_nat 0) :> Type.
    Proof.
      reflexivity.
    Qed.*)

    #[export]
    Instance from_nat_compat: Proper (Logic.eq ==> eq) from_nat := _.

    #[export]
    Instance from_nat_strict_covariace: Proper (Peano.lt ==> lt) from_nat.
    Proof.
      repeat intro.
      rewrite <- from_wf_is_from_nat.
      apply from_wf_strict_covariance, H.
    Qed.

    #[export]
    Instance from_nat_covariance: Proper (Peano.le ==> le) from_nat.
    Proof.
      intros m n m_le_n.
      induction m, n as [n | m | m n IH] using nat_double_ind.
      - (* 0, n *) apply zero_le.
      - (* S m, 0 *) exfalso. inversion m_le_n.
      - (* S m, S n *)
        simpl; repeat elim_quantifiers.
        apply IH. auto with arith.
    Qed.

    Property from_nat_le_inv m n: from_nat m ≤ from_nat n → (m <= n)%nat.
    Proof.
      induction m, n as [n | m | m n IH] using nat_double_ind.
      simpl; intro H; repeat elim_quantifiers.
      auto with arith.
    Qed.

    Property from_nat_inj m n: from_nat m == from_nat n → m = n.
      intros [H₁ H₂].
      apply from_nat_le_inv in H₁, H₂.
      auto with arith.
    Qed.

  End From_Nat.

  Section Supremum.
    (** The supremum, or join, of an indexed family of ordinals.
        Conceptually we join all their sources into a sigma-type and
        take the strict supremum of the corresponding join of their
        source maps.
        *)

    Open Scope equiv_scope.

    Section Def.

      Context `(x: A → Ord).

      Let J: Type := { a: A & src (x a) }.

      Let Jmap: J → Ord := λ j, let (a, b) := j in src_map (x a) b.

      Definition sup: Ord := ssup Jmap.

      Property sup_ge: ∀ a: A, x a ≤ sup.
      Proof.
        intro a. destruct (x a) as [B y] eqn: E.
        intro b.
        exists (existT _ a (eq_rect _ _ b _ (symmetry E))).
        unfold sup; simpl. rewrite -> E. reflexivity.
      Qed.

      Property sup_minimality: ∀ s, (forall a, x a ≤ s) → sup ≤ s.
      Proof.
        intros s H. destruct s eqn: E.
        apply le_lt.
        intros [a b]. rewrite <- (H a).
        simpl. destruct (x a). apply ssup_gt.
      Qed.

      Property sup_uniqueness:
      ∀ s, (∀ a, x a ≤ s) → (∀ s', (∀ a, x a ≤ s') → s ≤ s') → sup == s.
      Proof.
        split.
        - apply sup_minimality; auto.
        - apply H0, sup_ge.
      Qed.

      Property sup_maximum: ∀ a:A, (∀ b:A, x b ≤ x a) → x a == sup.
      Proof.
        intros. split.
        - apply sup_ge.
        - apply sup_minimality; assumption.
      Qed.

    End Def.

    #[export]
    Instance sup_covariance {A}: Proper (pointwise_relation A le ==> le) sup.
    Proof λ x y H,
          sup_minimality x (sup y) (transitivity H (sup_ge y)).

    #[export]
    Instance sup_compat {A}: Proper (pointwise_relation A eq ==> eq) sup := _.

    Property sup_le_ssup [A]: pointwise_relation _ le (@sup A) (@ssup A).
    Proof.
      intro x. apply sup_minimality, ssup_ge.
    Qed.

    Proposition ssup_is_sup_succ [A] (x: A → Ord): ssup x == sup (succ ∘ x).
    Proof.
      split; simpl.
      - intro a; exists (existT _ a tt). reflexivity.
      - intros [a []]; exists a. reflexivity.
    Qed.

    Proposition succ_sup [A] (x: A → Ord): sup x < ssup x ↔ succ (sup x) == ssup x.
    Proof.
      split.
      + split.
        - apply le_lt; trivial.
        - cbn. intro a; exists tt; apply sup_ge.
      + intro H; rewrite <- H; apply succ_gt.
    Qed.

    Proposition sup_empty_is_zero [A] (x: A → Ord): ¬inhabited A → sup x == zero.
    Proof.
      intro N; apply le_zero_is_zero.
      intros [a]; now contradict N.
    Qed.

    Remark sup_const_le x [A]: sup (const x : A → Ord) ≤ x.
    Proof.
      apply sup_minimality; reflexivity.
    Qed.

    Remark sup_const_eq x [A]: inhabited A → sup (const x : A → Ord) == x.
    Proof.
      split. 1: apply sup_const_le.
      destruct H as [a].
      change x with (const x a) at 2. apply sup_ge.
    Qed.

  End Supremum.

  Section Pairwise_Maximum.

    Definition max (x y: Ord): Ord := ssup (sum_rect _ (src_map x) (src_map y)).
    Local Notation "[ f , g ]" := (sum_rect _ f g).

    Property max_ge x y: x ≤ max x y ∧ y ≤ max x y.
    Proof.
      destruct x, y. split. intro a.
      1: exists (inl a). 2: exists (inr a).
      reflexivity.
    Qed.

    Definition max_ge_L x y := proj1 (max_ge x y): x ≤ max x y.
    Definition max_ge_R x y := proj2 (max_ge x y): y ≤ max x y.

    Property max_minimality x y: ∀ z, x ≤ z → y ≤ z → max x y ≤ z.
    Proof.
      destruct x, y, z; simpl.
      intros H1 H2 p. destruct p as [a | a].
      1: destruct (H1 a). 2: destruct (H2 a).
      eexists; eassumption.
    Qed.

    Corollary max_uniqueness x y: ∀ m,
      x ≤ m → y ≤ m → (∀ z, x ≤ z → y ≤ z → m ≤ z) → max x y == m.
    Proof.
      split.
      - apply max_minimality; assumption.
      - apply H1; apply max_ge.
    Qed.

    Proposition max_is_sup x y: max x y == sup (λ b:bool, if b then x else y).
    Proof.
      split.
      - apply max_minimality.
        + exact (sup_ge _ true).
        + exact (sup_ge _ false).
      - apply sup_minimality.
        intro b; case b. apply max_ge.
    Qed.

    #[export]
    Instance max_covariance: Proper (le ++> le ++> le) max.
    Proof.
      intros [A f] [B g] Le [A' f'] [B' g'] Le'.
      intro x; destruct x as [a | a].
      - destruct (Le a) as [x]; now exists (inl x).
      - destruct (Le' a) as [x]; now exists (inr x).
    Qed.

    #[export]
    Instance max_compat: Proper (eq ==> eq ==> eq) max := _.

    Property max_idempotence x: max x x == x.
    Proof.
      destruct x as [A f]; apply eq_eq.
      - intros [a | a]; now exists a.
      - intro a; now exists (inl a).
    Qed.

    Property max_sym x y: max x y == max y x.
    Proof.
      apply eq_eq. intros [a | a].
      1, 3: exists (inr a). 3, 4: exists (inl a).
      reflexivity.
    Qed.

    Property max_eq_L x y: x ≥ y ↔ max x y == x.
    Proof.
      split.
      - split.
        + rewrite <- H; apply max_idempotence.
        + apply max_ge.
      - intro H; rewrite <- H; apply max_ge.
    Qed.

    Property max_eq_R x y: x ≤ y ↔ max x y == y.
    Proof.
      rewrite max_sym. apply max_eq_L.
    Qed.

  End Pairwise_Maximum.

  Section Pairwise_Minimum.

    Fixpoint min (x y: Ord): Ord :=
      ssup (λ p: src x × src y, min (src_map x (fst p)) (src_map y (snd p))).

    Fixpoint min_le (x y: Ord): min x y ≤ x ∧ min x y ≤ y.
    Proof.
      destruct x, y; split; intros [a b].
      1: exists a. 2: exists b.
      apply min_le.
    Qed.

    Definition min_le_L x y := proj1 (min_le x y) : min x y ≤ x.
    Definition min_le_R x y := proj2 (min_le x y) : min x y ≤ y.

    Fixpoint min_maximality x y: ∀ z, z ≤ x → z ≤ y → z ≤ min x y.
    Proof.
      destruct x as [A x], y as [B y], z as [C z]. cbn.
      intros H1 H2 c.
      specialize (H1 c) as [a H1]; specialize (H2 c) as [b H2].
      exists (a, b). now_show (z c ≤ min (x a) (y b)).
      now apply min_maximality.
    Qed.

    Corollary min_uniqueness x y: ∀ m,
      m ≤ x → m ≤ y → (∀ z, z ≤ x → z ≤ y → z ≤ m) → min x y == m.
    Proof.
      split.
      - apply H1; apply min_le.
      - apply min_maximality; assumption.
    Qed.

    #[export]
    Instance min_covariance: Proper (le ++> le ++> le) min.
    Proof.
      intros [A f] [B g] Le [A' f'] [B' g'] Le'. simpl.
      intros (a, a').
      specialize (Le a) as (b, Le); fold le in Le.
      specialize (Le' a') as (b', Le'); fold le in Le'.
      exists (b, b'); cbn in *.
      apply min_maximality.
      1: rewrite <- Le. 2: rewrite <- Le'.
      apply min_le.
    Qed.

    #[export]
    Instance min_compat: Proper (eq ==> eq ==> eq) min := _.

  End Pairwise_Minimum.

End Ord.

#[global] Bind Scope Ord_scope with Ord Ord.t.

#[global] Infix "≤" := Ord.le: Ord_scope.
#[global] Infix "≥" := Ord.ge: Ord_scope.
#[global] Infix "<" := Ord.lt: Ord_scope.
#[global] Infix ">" := Ord.gt: Ord_scope.
#[global] Infix "==" := Ord.eq: Ord_scope.
#[global] Notation "x =/= y" := (not (Ord.eq x y)): Ord_scope.

#[global] Notation "x == y == z" := (and (Ord.eq x y) (Ord.eq y z)): Ord_scope.
#[global] Notation "x < y < z" := (and (Ord.lt x y) (Ord.lt y z)): Ord_scope.
#[global] Notation "x ≤ y ≤ z" := (and (Ord.le x y) (Ord.le y z)): Ord_scope.
#[global] Notation "x ≤ y < z" := (and (Ord.le x y) (Ord.lt y z)): Ord_scope.
#[global] Notation "x < y ≤ z" := (and (Ord.lt x y) (Ord.le y z)): Ord_scope.
#[global] Notation "x < y == z" := (and (Ord.lt x y) (Ord.eq y z)): Ord_scope.
#[global] Notation "x == y < z" := (and (Ord.eq x y) (Ord.lt y z)): Ord_scope.
#[global] Notation "x ≤ y == z" := (and (Ord.le x y) (Ord.eq y z)): Ord_scope.
#[global] Notation "x == y ≤ z" := (and (Ord.eq x y) (Ord.le y z)): Ord_scope.

#[export] Instance Ord_eq_rewrite: RewriteRelation Ord.eq | 0 := {}.
#[export] Instance Ord_lt_rewrite: RewriteRelation Ord.lt | 1 := {}.
#[export] Instance Ord_le_rewrite: RewriteRelation Ord.le | 1 := {}.
#[export] Instance Ord_gt_rewrite: RewriteRelation Ord.lt | 2 := {}.
#[export] Instance Ord_ge_rewrite: RewriteRelation Ord.ge | 2 := {}.


(* Source : https://erikmd.github.io/tryjscoq/tapfa/tad.v *)

Require Import List. Import ListNotations.
Set Implicit Arguments.

Module Type Monoide.
  Parameter T : Type.           (* une sorte *)
  Parameter un : T.             (* une constante *)
  Parameter prod : T -> T -> T. (* une opération *)

  Axiom assoc : forall x y z:T, prod x (prod y z) = prod (prod x y) z.
  Axiom neutre_g : forall x, prod un x = x.
  Axiom neutre_d : forall x, prod x un = x.
End Monoide.

Module MonoList <: Monoide. (* vérification sans masquage *)
  Definition T := list nat.
  Definition un : T := [].
  Definition prod (x y : T) := x ++ y.
  Lemma assoc : forall x y z:T, prod x (prod y z) = prod (prod x y) z.
  Proof. apply app_assoc. Qed.
  Lemma neutre_g : forall x, prod un x = x.
  Proof. reflexivity. Qed.
  Lemma neutre_d : forall x, prod x un = x.
  Proof. induction x; auto. simpl. rewrite IHx. reflexivity. Qed.
End MonoList.

Module Use (M : Monoide).
  Theorem unicite : forall u : M.T, (forall x, M.prod x u = x) -> u = M.un.
  Proof.
  intros u Hu.
  rewrite <-(Hu M.un).
  rewrite M.neutre_g.
  reflexivity.
  Qed.
End Use.

Module Inst := Use(MonoList).
Check Inst.unicite.
(* : forall u : MonoList.T, (forall x : MonoList.T, MonoList.prod x u = x) -> u = MonoList.un *)

Print MonoList.un.
(* MonoList.un = [] : MonoList.T *)
Print MonoList.T.
(* MonoList.T = list nat : Set *)

Module Type Pile.
  Parameter Elem: Type.
  Parameter P: Type.

  Parameter vide: P.
  Parameter push: Elem -> P -> P.
  Parameter estVide: P -> bool.
  Parameter pop: P -> P.
  Parameter top: P -> option Elem.

  Axiom estVide_vide: estVide vide = true.
  Axiom estVide_push: forall p e, estVide (push e p) = false.
  Axiom top_vide: top vide = None.
  Axiom top_push: forall p e, top (push e p) = Some e.
  Axiom pop_vide: pop vide = vide.
  Axiom pop_push: forall p e, pop (push e p) = p.
End Pile.

Module Pile_Liste <: Pile.
  Definition Elem := nat.
  Definition P := list nat.
  Definition vide : P := [].
  Definition push (e: Elem) (p: P) := e :: p.
  Definition estVide (p: P) :=
    match p with [] => true | _ => false end.
  Definition top (p: P) :=
    match p with [] => None | x :: _ => Some x end.
  Definition pop (p: P) :=
    match p with [] => [] | _ :: l => l end.

  Lemma estVide_vide: estVide vide = true.
  Proof.
  Admitted.

  Lemma estVide_push: forall p e, estVide (push e p) = false.
  Proof.
  Admitted.

  Lemma top_vide: top vide = None.
  Proof.
  Admitted.

  Lemma top_push: forall p e, top (push e p) = Some e.
  Proof.
  Admitted.

  Lemma pop_vide: pop vide = vide.
  Proof.
  Admitted.

  Lemma pop_push: forall p e, pop (push e p) = p.
  Proof.
  Admitted.
End Pile_Liste.

Module Pile_QListe <: Pile.
  Definition Elem := nat.
  Definition P := list nat.
  Definition vide : P := [].
  Definition push (e: Elem) (p: P) := p ++ [e].
  Definition estVide (p: P) :=
    match p with [] => true | _ => false end.
  Fixpoint top (p: P) :=
    match p with
    | [] => None
    | [e] => Some e
    | x :: l => top l
    end.
  Fixpoint pop (p: P) :=
    match p with
    | [] => []
    | [e] => []
    | x :: l => x :: pop l
    end.

  Lemma estVide_vide: estVide vide = true.
  Proof.
  Admitted.

  Lemma estVide_push: forall p e, estVide (push e p) = false.
  Proof.
  Admitted.

  Lemma top_vide: top vide = None.
  Proof.
  Admitted.

  Lemma top_push: forall p e, top (push e p) = Some e.
  Proof.
  Admitted.

  Lemma pop_vide: pop vide = vide.
  Proof.
  Admitted.

  Lemma pop_push: forall p e, pop (push e p) = p.
  Proof.
  Admitted.

End Pile_QListe.


Require Import Lia.

Inductive tree : Type :=
| o : tree
| T : tree -> tree -> tree.

Fixpoint branches (t : tree) :=
match t with
| o => 0
| T t1 t2 => 1 + (branches t1) + (branches t2)
end.

Fixpoint normal (T : tree) : Prop :=
match T with
| o => True
| T o t => normal t
| _ => False
end.

Inductive Eq : tree -> tree -> Prop :=
| EqRef : forall t, Eq t t
| EqSym : forall s t, Eq s t -> Eq t s
| EqTran : forall x y z, Eq x y -> Eq y z -> Eq x z
| EqAsso : forall t1 t2 t3, Eq ( T (T t1 t2) t3 ) (T t1 (T t2 t3) )
| EqT : forall t1 t2 s1 s2, Eq t1 s1 -> Eq t2 s2 -> Eq (T t1 t2) (T s1 s2).

Require Import Setoid Morphisms.

Instance : Equivalence Eq.
Proof.
  split.
  intros t. exact (EqRef t).
  intros s t H. apply EqSym; auto.
  intros x y z H1 H2. exact (EqTran x y z H1 H2).
Defined.

Instance T_congruent :
  Proper (Eq ==> Eq ==> Eq) T.
Proof.
  intros t s Eq t' s' Eq'. apply EqT; auto.
Qed.

Instance branch_congruent :
  Proper (Eq ==> (@eq nat)) branches.
Proof.
  intros t s H. induction H; cbn; lia.
Qed.

Lemma free_leaf t :
  t <> o -> (exists t', Eq t (T o t') ).
Proof.
  intros noLeaf. induction t. now exists o.
  destruct t1.
  - now exists t2.
  - assert (T t1_1 t1_2 <> o) as H by discriminate.
    destruct (IHt1 H) as [t' H']. exists (T t' t2).
    now rewrite H', EqAsso.
Qed.

Lemma ex_iff {X} (P Q : X -> Prop) :
  (forall x, P x <-> Q x) -> (exists x, P x) <-> (exists x, Q x).
Proof.
  firstorder.
Qed.

Theorem pre_normalization : forall (n: nat)(t : tree),
  branches t < n -> exists t', normal t'  /\ Eq t t'.
Proof.
  induction n. destruct t; cbn; lia.
  destruct t; intro Bran. exists o; cbn; split. auto. apply EqRef.
  cbn in Bran. destruct t1.
  - assert (branches t2 < n) as H by lia.
    destruct (IHn _ H) as [s [? E]].
    exists (T o s). split; cbn; try tauto.
    rewrite E; apply EqRef.
  - assert (T t1_1 t1_2 <> o) as  Triv by discriminate.
    destruct ( free_leaf (T t1_1 t1_2) Triv ) as [t1 N1].
    eapply (ex_iff (fun x => normal x /\ Eq (T (T o t1) t2) x)).
    { intros x. now rewrite N1. }
    assert (branches t2 < S n) as H by lia.
    rewrite N1 in Bran; cbn in Bran.
    assert (S (branches t1 + branches t2) < n) as H' by lia.
    change (branches (T t1 t2) < n) in H'.
    destruct (IHn _ H') as [s [? E]].
    exists (T o s). split; cbn; try tauto.
    now rewrite EqAsso, E.
Qed.

Corollary normalization : forall t, exists t', normal t' /\ Eq t t'.
Proof.
  intros t. apply (pre_normalization ( S(branches t)) ). lia.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearright.
Require Export GeoCoq.Elements.OriginalProofs.lemma_rightreverse.
Require Export GeoCoq.Elements.OriginalProofs.lemma_altitudebisectsbase.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_droppedperpendicularunique :
   forall A J M P,
   Per A M P -> Per A J P -> Col A M J ->
   eq M J.
Proof.
intros.
assert (~ neq M J).
 {
 intro.
 assert (neq J M) by (conclude lemma_inequalitysymmetric).
 let Tf:=fresh in
 assert (Tf:exists E, (BetS M J E /\ Cong J E M J)) by (conclude lemma_extension);destruct Tf as [E];spliter.
 assert (neq M E) by (forward_using lemma_betweennotequal).
 let Tf:=fresh in
 assert (Tf:exists F, (BetS J M F /\ Cong M F M E)) by (conclude lemma_extension);destruct Tf as [F];spliter.
 assert (BetS E J M) by (conclude axiom_betweennesssymmetry).
 assert (BetS E J F) by (conclude lemma_3_7b).
 assert (BetS F J E) by (conclude axiom_betweennesssymmetry).
 assert (BetS E M F) by (conclude lemma_3_7a).
 assert (neq J F) by (forward_using lemma_betweennotequal).
 assert (neq F J) by (conclude lemma_inequalitysymmetric).
 assert (Col J M F) by (conclude_def Col ).
 assert (Col M J F) by (forward_using lemma_collinearorder).
 assert (Col M J A) by (forward_using lemma_collinearorder).
 assert (neq J M) by (forward_using lemma_betweennotequal).
 assert (neq M J) by (conclude lemma_inequalitysymmetric).
 assert (Col J F A) by (conclude lemma_collinear4).
 assert (Col A J F) by (forward_using lemma_collinearorder).
 assert (Per F J P) by (conclude lemma_collinearright).
 assert (Col J M F) by (conclude_def Col ).
 assert (Col J M A) by (forward_using lemma_collinearorder).
 assert (Col M F A) by (conclude lemma_collinear4).
 assert (Col A M F) by (forward_using lemma_collinearorder).
 assert (neq M F) by (forward_using lemma_betweennotequal).
 assert (neq F M) by (conclude lemma_inequalitysymmetric).
 assert (Per F M P) by (conclude lemma_collinearright).
 assert (Cong F M M E) by (forward_using lemma_congruenceflip).
 assert (Per F M P) by (conclude lemma_collinearright).
 assert (BetS F M E) by (conclude axiom_betweennesssymmetry).
 assert (Cong F P E P) by (conclude lemma_rightreverse).
 assert (Midpoint F J E) by (conclude lemma_altitudebisectsbase).
 assert (BetS F M E) by (conclude axiom_betweennesssymmetry).
 assert (Cong F M M E) by (forward_using lemma_congruenceflip).
 assert (Midpoint F M E) by (conclude_def Midpoint ).
 assert (eq J M) by (conclude lemma_midpointunique).
 contradict.
 }
close.
Qed.

End Euclid.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

(* Why3 comment *)
(* abs is replaced with (ZArith.BinInt.Z.abs x) by the coq driver *)

(* Why3 goal *)
Lemma abs_def : forall (x:Z), ((0%Z <= x)%Z ->
  ((ZArith.BinInt.Z.abs x) = x)) /\ ((~ (0%Z <= x)%Z) ->
  ((ZArith.BinInt.Z.abs x) = (-x)%Z)).
intros x.
split ; intros H.
now apply Zabs_eq.
apply Zabs_non_eq.
apply Znot_gt_le.
contradict H.
apply Zlt_le_weak.
now apply Zgt_lt.
Qed.

(* Why3 goal *)
Lemma Abs_le : forall (x:Z) (y:Z), ((ZArith.BinInt.Z.abs x) <= y)%Z <->
  (((-y)%Z <= x)%Z /\ (x <= y)%Z).
intros x y.
zify.
omega.
Qed.

(* Why3 goal *)
Lemma Abs_pos : forall (x:Z), (0%Z <= (ZArith.BinInt.Z.abs x))%Z.
exact Zabs_pos.
Qed.


(** Calculation of an abstract machine for the call-by-name lambda
calculus. The resulting abstract machine (almost) coincides with the
Krivine machine. The relation to the Krivine machine is explained
below. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** We start with the evaluator for this language, which is taken from
Ager et al. "A functional correspondence between evaluators and
abstract machines" (we use Haskell syntax to describe the evaluator):
<<
type Env   = [Thunk]
data Thunk = Thunk (() -> Value)
data Value = Clo (Thunk -> Value)

eval :: Expr -> Env -> Value
eval (Var i)   e = case e !! i of
                     Thunk t -> t ()
eval (Abs x)   e = Clo (\t -> eval x (t : e))
eval (App x y) e = case eval x e of
                     Clo f -> f (Thunk (\_ -> eval y e))
>>
After defunctionalisation and translation into relational form we
obtain the semantics below.  *)

Inductive Thunk : Set  :=
  | thunk : Expr -> list Thunk -> Thunk.

Definition Env : Set := list Thunk.

Inductive Value : Set :=
| Clo : Expr -> Env -> Value.

Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Value -> Prop :=
| eval_var e e' x i v : nth e i = Some (thunk x e') -> x ⇓[e'] v -> Var i ⇓[e] v
| eval_abs e x : Abs x ⇓[e] Clo x e
| eval_app e e' x x' v y  : x ⇓[e] Clo x' e' -> x' ⇓[thunk y e :: e'] v -> App x y ⇓[e] v
where "x ⇓[ e ] y" := (eval x e y).

(** * Abstract machine *)

Inductive CONT : Set :=
| APP : Expr -> Env -> CONT -> CONT
| HALT : CONT
.

Inductive Conf : Set :=
| eval'' : Expr -> Env -> CONT -> Conf
| apply : CONT -> Value -> Conf.

Notation "⟨ x , e , c ⟩" := (eval'' x e c).
Notation "⟪ c , v ⟫" := (apply c v).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive AM : Conf -> Conf -> Prop :=
| am_var i e c x e' : nth e i = Some (thunk x e') -> ⟨Var i, e, c⟩ ==> ⟨x, e', c⟩
| am_abs x e c : ⟨Abs x, e, c⟩ ==> ⟪c, Clo x e⟫
| am_app x y e c : ⟨App x y, e, c⟩ ==> ⟨x, e, APP y e c⟩
| am_APP y e c x' e' : ⟪APP y e c, Clo x' e'⟫ ==> ⟨x', thunk y e::e', c⟩
where "x ==> y" := (AM x y).

(** The only difference between the above machine and the Krivine
machine is that the former produces via the rule [am_abs] a state of
the form [⟪...⟫], which is then immediately consumed by the rule
[am_APP]. These two rules [am_abs] and [am_APP] can therefore be fused
into a single rule. The resulting machine is exactly coincides with
the Krivine machine. *)

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module AM <: Preorder.
Definition Conf := Conf.
Definition VM := AM.
End AM.
Module AMCalc := Calculation AM.
Import AMCalc.

(** Specification of the abstract machine *)

Theorem spec x e r c : x ⇓[e] r -> ⟨x, e, c⟩ =>> ⟪c, r⟫.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction H;intros.

(** Calculation of the abstract machine *)

(** - [Var i ⇓[e] v] *)

  begin
    ⟪c, v ⟫.
  <<= {apply IHeval}
    ⟨x, e', c ⟩.
  <== {apply am_var}
    ⟨Var i, e, c⟩.
  [].

(** - [Abs x ⇓[e] Clo x e] *)

  begin
    ⟪c, Clo x e⟫.
  <== { apply am_abs }
    ⟨Abs x, e, c⟩.
  [].

(** - [App x y ⇓[e] w] *)

  begin
    ⟪c, v⟫.
  <<= { apply IHeval2 }
    ⟨x', (thunk y e::e'), c⟩.
  <== { apply am_APP }
    ⟪APP y e c, Clo x' e'⟫.
  <<= {apply IHeval1}
    ⟨x, e, APP y e c⟩.
  <== {apply am_app}
    ⟨App x y, e, c⟩.
  [].
Qed.

(** * Soundness *)

Lemma determ_am : determ AM.
  intros C c1 c2 V. induction V; intro V'; inversion V'; subst; congruence.
Qed.

Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r.

Theorem sound x C : terminates x -> ⟨x, nil, HALT⟩ =>>! C ->
                          exists r, C = ⟪HALT, r⟫ /\ x ⇓[nil] r.
Proof.
  unfold terminates. intros. destruct H as [r T].

  pose (spec x nil r HALT) as H'. exists r. split. pose (determ_trc determ_am) as D.
  unfold determ in D. eapply D. eassumption. split. eauto. intro. destruct H.
  inversion H. assumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax.

(** * Maximum and Minimum of two real numbers *)

Local Open Scope R_scope.

(** The functions [Rmax] and [Rmin] implement indeed
    a maximum and a minimum *)

Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Module RHasMinMax <: HasMinMax R_as_OT.
 Definition max := Rmax.
 Definition min := Rmin.
 Definition max_l := Rmax_l.
 Definition max_r := Rmax_r.
 Definition min_l := Rmin_l.
 Definition min_r := Rmin_r.
End RHasMinMax.

Module R.

(** We obtain hence all the generic properties of max and min. *)

Include UsualMinMaxProperties R_as_OT RHasMinMax.

(** * Properties specific to the [R] domain *)

(** Compatibilities (consequences of monotonicity) *)

Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m.
Proof.
 intros. apply max_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m.
Proof.
 intros. apply min_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_min_distr_l.
Qed.

(** Anti-monotonicity swaps the role of [min] and [max] *)

Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m).
Proof.
 intros. symmetry. apply min_max_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m).
Proof.
 intros. symmetry. apply max_min_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m.
Proof.
 unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
Qed.

Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p.
Proof.
 unfold Rminus. intros. apply plus_max_distr_r.
Qed.

Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m.
Proof.
 unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
Qed.

Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p.
Proof.
 unfold Rminus. intros. apply plus_min_distr_r.
Qed.

End R.


(** 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.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

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


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.LetIn.
Local Open Scope Z_scope.

Module Z.
  Definition pow2_mod n i := (n &' (Z.ones i)).

  Definition zselect (cond zero_case nonzero_case : Z) :=
    if cond =? 0 then zero_case else nonzero_case.

  Definition add_modulo x y modulus :=
    if (modulus <=? x + y) then (x + y) - modulus else (x + y).

  Definition get_carry (bitwidth : Z) (v : Z) : Z * Z
    := (v mod 2^bitwidth, v / 2^bitwidth).
  Definition add_with_carry (c : Z) (x y : Z) : Z
    := c + x + y.
  Definition add_with_get_carry (bitwidth : Z) (c : Z) (x y : Z) : Z * Z
    := get_carry bitwidth (add_with_carry c x y).
  Definition add_get_carry (bitwidth : Z) (x y : Z) : Z * Z
    := add_with_get_carry bitwidth 0 x y.

  Definition get_borrow (bitwidth : Z) (v : Z) : Z * Z
    := let '(v, c) := get_carry bitwidth v in
       (v, -c).
  Definition sub_with_borrow (c : Z) (x y : Z) : Z
    := add_with_carry (-c) x (-y).
  Definition sub_with_get_borrow (bitwidth : Z) (c : Z) (x y : Z) : Z * Z
    := get_borrow bitwidth (sub_with_borrow c x y).
  Definition sub_get_borrow (bitwidth : Z) (x y : Z) : Z * Z
    := sub_with_get_borrow bitwidth 0 x y.

  (* splits at [bound], not [2^bitwidth]; wrapper to make add_getcarry
  work if input is not known to be a power of 2 *)
  Definition add_get_carry_full (bound : Z) (x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then add_get_carry (Z.log2 bound) x y
       else ((x + y) mod bound, (x + y) / bound).
  Definition add_with_get_carry_full (bound : Z) (c x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then add_with_get_carry (Z.log2 bound) c x y
       else ((c + x + y) mod bound, (c + x + y) / bound).
  Definition sub_get_borrow_full (bound : Z) (x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then sub_get_borrow (Z.log2 bound) x y
       else ((x - y) mod bound, -((x - y) / bound)).
  Definition sub_with_get_borrow_full (bound : Z) (c x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then sub_with_get_borrow (Z.log2 bound) c x y
       else ((x - y - c) mod bound, -((x - y - c) / bound)).

  Definition mul_split_at_bitwidth (bitwidth : Z) (x y : Z) : Z * Z
    := dlet xy := x * y in
        (match bitwidth with
         | Z.pos _ | Z0 => xy &' Z.ones bitwidth
         | Z.neg _ => xy mod 2^bitwidth
         end,
         match bitwidth with
         | Z.pos _ | Z0 => xy >> bitwidth
         | Z.neg _ => xy / 2^bitwidth
         end).
  Definition mul_split (s x y : Z) : Z * Z
    := if s =? 2^Z.log2 s
       then mul_split_at_bitwidth (Z.log2 s) x y
       else ((x * y) mod s, (x * y) / s).
End Z.


(** * The very classical example of GCD computation in Hoare logic.

 This file is part of the "Tutorial on Hoare Logic".
 For an introduction to this Coq library,
 see README #or index.html#.

 This file illustrates how to use the Hoare logic described in file
 ##[hoarelogicsemantics]##

 I use here the very classical example of "great common divisor"
 computations through successive subtractions.
*)

Set Implicit Arguments.

Require Import ZArith.
Require Import Znumtheory.
Require Import Bool.
Require Import hoarelogic.
Require Import Zwf.
Require Import Wellfounded.

(** * Implementation of the expression language *)
Module Example <: ExprLang.

(** Here, I use only two global variables [VX] and [VY] of type [Z]
(binary integers). *)
Inductive ExVar: Type -> Type :=
  VX: (ExVar Z) |
  VY: (ExVar Z).

Definition Var:=ExVar.

(** An environment is just a pair of integers. First component
represents [VX] and second component represents [VY].  This is
expressed in [upd] and [get] below. *)
Definition Env:= (Z*Z)%type.

Definition upd (A:Type): (ExVar A) -> A -> Env -> Env :=
 fun x =>
   match x in (ExVar A) return A -> Env -> Env with
   | VX => fun vx e => (vx,snd e)
   | VY => fun vy e => (fst e,vy)
   end.

Definition get (A:Type): (ExVar A) -> Env -> A :=
 fun x =>
   match x in (ExVar A) return Env -> A with
   | VX => fun e => fst e
   | VY => fun e => snd e
   end.

(** I consider only two binary operators [PLUS] and [MINUS]. Their
meaning is given by [eval_binOP] below *)
Inductive binOP: Type := PLUS | MINUS.

Definition eval_binOP: binOP -> Z -> Z -> Z :=
 fun op => match op with
  | PLUS => Zplus
  | MINUS => Zminus
 end.

(** I consider only three comparison operators [EQ], [NEQ] and
[LE]. Their meaning is given by [eval_relOP] below *)
Inductive relOP: Type := EQ | NEQ | LE.

Definition eval_relOP: relOP -> Z -> Z -> bool :=
 fun op => match op with
  | EQ => Zeq_bool
  | NEQ => Zneq_bool
  | LE => Zle_bool
 end.

(** Here is the abstract syntax of expressions. The semantics is given
by [eval] below *)
Inductive ExExpr: Type -> Type :=
 | const: forall (A:Type), A -> (ExExpr A)
 | binop: binOP -> (ExExpr Z) -> (ExExpr Z) -> (ExExpr Z)
 | relop: relOP -> (ExExpr Z) -> (ExExpr Z) -> (ExExpr bool)
 | getvar: forall (A:Type), (ExVar A) -> (ExExpr A).

Definition Expr:= ExExpr.

Fixpoint eval (A:Type) (expr:Expr A) (e:Env) { struct expr } : A :=
 match expr in ExExpr A return A with
 | const A v => v
 | binop op e1 e2 => eval_binOP op (eval e1 e) (eval e2 e)
 | relop op e1 e2 => eval_relOP op (eval e1 e) (eval e2 e)
 | getvar A x => (get x e)
end.

End Example.

(** * Instantiation of the Hoare logic on this langage. *)
Module HL :=  HoareLogic(Example).
Import HL.
Import Example.

(** These coercions makes the abstract syntax more user-friendly *)
Coercion getvar: ExVar >-> ExExpr.
Coercion binop: binOP >-> Funclass.
Coercion relop: relOP >-> Funclass.

(** A last coercion useful for assertions *)
Coercion get: ExVar >-> Funclass.

(** ** A [gcd] computation in this language *)
Definition gcd :=
  (Iwhile (NEQ VX VY)
          (Iif (LE VX VY)
               (Iset VY (MINUS VY VX))
               (Iset VX (MINUS VX VY)))).

(** A small technical lemma on the mathematical notion of gcd (called
[Zis_gcd]) *)
Lemma Zgcd_minus: forall a b d:Z, Zis_gcd a (b - a) d -> Zis_gcd a b d.
Proof.
  intros a b d H; case H; constructor; intuition (auto with zarith).
  replace b with (b-a+a)%Z.
  auto with zarith.
  omega.
Qed.

Hint Resolve Zgcd_minus: zarith.

(** Two other lemmas relating [Zneq_bool] function with inequality
relation *)
Lemma Zneq_bool_false: forall x y, Zneq_bool x y=false -> x=y.
Proof.
 intros x y H0; apply Zcompare_Eq_eq; generalize H0; clear H0; unfold Zneq_bool. case (x ?= y)%Z; auto;
 try (intros; discriminate); auto.
Qed.

Lemma Zneq_bool_true: forall x y, Zneq_bool x y=true -> x<>y.
Proof.
 intros x y; unfold Zneq_bool.
 intros H H0; subst.
 rewrite Zcompare_refl in H.
 discriminate.
Qed.

Hint Resolve Zneq_bool_true Zneq_bool_false Zle_bool_imp_le Zis_gcd_intro: zarith.

(** ** Partial correctness proof of [gcd] *)
Lemma gcd_partial_proof:
 forall x0 y0, (fun e => (VX e)=x0 /\ (VY e)=y0)
   |= gcd  {= fun e => (Zis_gcd x0 y0 (VX e)) =}.
Proof.
 intros x0 y0.
 apply PHL.soundness.
 simpl.
 intros e; intuition subst.
 (** after PO generation, I provide the invariant and simplify the goal *)
 constructor 1 with (x:=fun e'=>
  forall d, (Zis_gcd (VX e') (VY e') d)
              ->(Zis_gcd (VX e) (VY e) d)); simpl.
 intuition auto with zarith.
 (** - invariant => postcondition *)
 cutrewrite <- ((fst e')=(snd e')) in H; auto with zarith.
Qed.

(** ** Total correctness proof of [gcd] *)

Lemma gcd_total_proof:
 forall x0 y0, (fun e => (VX e)=x0 /\ (VY e)=y0 /\ x0 > 0 /\ y0 > 0)
  |= gcd  [= fun e => (Zis_gcd x0 y0 (VX e)) =].
Proof.
 intros x0 y0.
 apply THL.soundness.
 simpl.
 intros e; intuition subst.
 (** after simplification, I provide the invariant and then the variant *)
 constructor 1 with (x:=fun e' => (VX e') > 0 /\ (VY e') > 0 /\
  forall d, (Zis_gcd (VX e') (VY e') d)
              ->(Zis_gcd (VX e) (VY e) d)); simpl.
 constructor 1 with (x:=fun e1 e0 => Zwf 0 ((VX e1)+(VY e1)) ((VX e0)+(VY e0))).
 (** - proof that my variant is a well_founded relation *)
 constructor 1.
 apply wf_inverse_image with (f:=fun e=>(VX e)+(VY e)).
 auto with datatypes.
 (** - other goals *)
  unfold Zwf; simpl; (intuition auto with zarith).
 (** -- invariant => postcondition
      --- gcd part like in partial correctness proof
 *)
  cutrewrite <- ((fst e')=(snd e')) in H5; auto with zarith.
  (** --- new VY in branch "then" is positive *)
  cut ((fst e')<=(snd e')); auto with zarith.
  cut ((fst e')<>(snd e')); auto with zarith.
  (** --- new VX in branch "else" is positive *)
  cut (~(fst e')<=(snd e')); auto with zarith.
  intros X; rewrite (Zle_imp_le_bool _ _ X) in H4.
  discriminate.
Qed.

(** ** Another example: infinite loops in partial correctness.

Basic Hoare logic is not well-suited for reasoning about non-terminating programs.
In total correctness, postconditions of non-terminating programs are not provable.
In partial correctness, a non-terminating program satisfies any (unsatisfiable) postcondition.

For example, in an informal "meaning", the program below enumerates all multiples of 3. But this meaning
can not be expressed here (even in partial correctness).
*)

Definition enum_3N :=
  (Iseq (Iset VX (const 0))
        (Iwhile (const true)
                (Iset VX (PLUS VX (const 3))))).

Lemma enum_3N_stupid:
 (fun e => True) |= enum_3N  {= fun e => False =}.
Proof.
 apply PHL.soundness.
 simpl.
 constructor 1 with (x:=fun _:Env => True).
 intuition (discriminate || auto).
Qed.

(** "Tutorial on Hoare Logic" Library. Copyright 2007 Sylvain Boulme.

This file is distributed under the terms of the
 "GNU LESSER GENERAL PUBLIC LICENSE" version 3.
*)


(*
(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.
*)

(** Common definitions of real functions sequences. *)
Require Import Cbase.
Require Import Cfunctions.
Require Import Csequence.
Require Import Canalysis_def.

Delimit Scope CFseq_scope with Cseq_scope.

Open Local Scope C_scope.
Open Local Scope CFseq_scope.

Implicit Type n : nat.
Implicit Type fn gn : nat -> C -> C.
Implicit Type f g : C -> C.

(** * Morphism of functions on R -> R to sequences. *)

Definition CFseq_plus fn gn n := (fn n + gn n)%F.
Definition CFseq_mult fn gn n := (fn n * gn n)%F.
Definition CFseq_opp fn n := (fun x => Copp (fn n x))%F.
Definition CFseq_inv fn n := (fun x => Cinv (fn n x))%F.

Infix "+" := CFseq_plus : CFseq_scope.
Infix "*" := CFseq_mult : CFseq_scope.
Notation "- u" := (CFseq_opp u) : CFseq_scope.
Notation "/ u" := (CFseq_inv u) : CFseq_scope.

Definition CFseq_minus fn gn n := (fn n - gn n)%F.
Definition CFseq_div fn gn n := (fn n / gn n)%F.

Infix "-" := CFseq_minus : CFseq_scope.
Infix "/" := CFseq_div : CFseq_scope.

(** * Convergence of functions sequences. *)

Definition CFseq_cv fn f := forall x, Cseq_cv (fun n => fn n x) (f x).
Definition CFseq_cv_boule fn f (c : C) (r : posreal) := forall x,  Boule c r x -> Cseq_cv (fun n => fn n x) (f x).

Definition CFseq_cvu fn f (x : C) (r : posreal) := forall eps : R, 0 < eps ->
        exists N : nat, forall n (y : C), (N <= n)%nat -> Boule x r y ->
        C_dist (fn n y) (f y) < eps.

Definition CFpartial_sum (fn : nat -> C) N := sum_f_C0 fn N.


(**
  ** The ring ([ring]) structure and variants such as integral domains ([idom]) and fields ([field]).
*)

Require Import ssr.
Require Import lib.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Rings *)

Section RingAxioms.

Variable R : eqType.
Variable add : R -> R -> R.
Variable mul : R -> R -> R.
Variable opp : R -> R.
Variable zero : R.
Variable one : R.

Notation "x1 + x2" := (add x1 x2).
Notation "x1 * x2" := (mul x1 x2).
Notation "- x" := (opp x).
Notation "0" := zero.
Notation "x - y" := (x + opp y).

Structure ring_axioms : Prop := Ring_axioms {
  addC': forall x1 x2 : R, x1 + x2 = x2 + x1;
  addA': forall x1 x2 x3 : R, x1 + (x2 + x3) = (x1 + x2) + x3;
  add0r' : forall x : R, x + 0 = x;
  oppL' : forall x : R, - x + x = 0;
  mulA' : forall x1 x2 x3 : R, x1 * (x2 * x3) = x1 * x2 * x3;
  distPM' : forall x1 x2 x3 : R, (x1 + x2) * x3 = x1 * x3 + x2 * x3;
  distMP' : forall x1 x2 x3 : R, x1 * (x2 + x3) = x1 * x2 + x1 * x3;
  mul1r' : forall x : R, one * x = x;
  mulr1' : forall x : R, x * one = x;
  mulC' : forall x1 x2 : R, x1 * x2 = x2 * x1
}.

End RingAxioms.

Module Ring.

Structure ring : Type := Ring {
  rbase :> eqType;
  add : rbase -> rbase -> rbase;
  mul : rbase -> rbase -> rbase;
  opp : rbase -> rbase;
  zero : rbase;
  one : rbase;
  axioms : ring_axioms add mul opp zero one
}.

End Ring.

Delimit Scope ring_scope with R.
Bind Scope ring_scope with Ring.rbase.

Arguments Scope Ring.add [_ ring_scope ring_scope].
Arguments Scope Ring.mul [_ ring_scope ring_scope].
Arguments Scope Ring.opp [_ ring_scope].

Definition addr := nosimpl Ring.add.
Definition oppr := nosimpl Ring.opp.
Definition mulr := nosimpl Ring.mul.
Definition zeror := nosimpl Ring.zero.
Definition oner := nosimpl Ring.one.

Implicit Arguments Ring.zero [].
Implicit Arguments Ring.one [].

Open Scope ring_scope.
Notation ring := Ring.ring (only parsing).
Notation "x1 + x2" := (addr x1 x2) : ring_scope.
Notation "x1 * x2" := (mulr x1 x2) : ring_scope.
Notation "- x" := (oppr x) : ring_scope.
Notation "0" := (zeror _) : ring_scope.
Notation "1" := (oner _) : ring_scope.
Notation "x - y" := (x + oppr y) : ring_scope.
Notation addrr := (fun x y => y + x).
Notation mulrr := (fun x y => y * x).

(** Identities and Basic Lemmas *)

Section Rings.

Variable R : ring.

Notation axioms := Ring.axioms.

Lemma oppL : forall x : R, -x + x = 0.
Proof. exact: oppL' (axioms _). Qed.

Lemma addr0 : forall x: R, x + 0 = x.
Proof. exact: add0r' (axioms _). Qed.

Lemma mulA : forall x y z : R, x * (y * z) = x * y * z.
Proof. exact: mulA' (axioms _). Qed.

Lemma distPM : forall x1 x2 x3 : R, (x1 + x2) * x3 = (x1 * x3) + (x2 * x3).
Proof.  exact: distPM' (axioms _). Qed.

Lemma distMP : forall x1 x2 x3 : R, x1 * (x2 + x3) = (x1 * x2) + (x1 * x3).
Proof. exact: distMP' (axioms _). Qed.

Lemma addC : forall x y : R, x + y = y + x.
Proof. exact: addC' (axioms _). Qed.

Lemma addA : forall x y z : R, x + (y + z) = (x + y) + z.
Proof. exact: addA' (axioms _). Qed.

Lemma add0r : forall x : R, 0 + x = x.
Proof. move=> x; rewrite addC; exact: addr0. Qed.

Lemma oppR : forall x : R, x + -x = 0.
Proof. move=> x. rewrite addC. exact: oppL. Qed.

Lemma addr_injl : forall x : R, injective (addr x).
Proof. by move=> x y z; move/(congr1 (addr (-x))); rewrite !addA !oppL !add0r. Qed.

Lemma addr_injr : forall x : R, injective (addrr x).
Proof. by move=> x y z /=; rewrite addC [z + _]addC; exact: addr_injl. Qed.

Lemma addKr : forall x : R, cancel (addr x) (addr (- x)).
Proof. by move=> x y; rewrite addA oppL add0r. Qed.

Lemma addKrV : forall x : R, cancel (addr (- x)) (addr x).
Proof. by move=> x y; rewrite addA oppR add0r. Qed.

Lemma addrK : forall x : R, cancel (addrr x) (addrr (- x)).
Proof. by move=> x y; rewrite -addA oppR addr0. Qed.

Lemma addrKV : forall x : R, cancel (addrr (- x)) (addrr x).
Proof. by move=> x y; rewrite -addA oppL addr0. Qed.

Lemma opp_opp : forall x : R, -(-x) = x.
Proof. by move=> x; apply: (@addr_injr (- x)); rewrite oppL oppR. Qed.

Lemma opp_uniq : forall x y y' : R, x + y = 0 -> x + y' = 0 -> y = y'.
Proof. by move=> x y y' H H'; apply (@addr_injl x); rewrite H H'. Qed.

Lemma opp_def : forall x y : R, x + y = 0 -> y = - x.
Proof. move=> x y H; apply (@opp_uniq x);auto; by rewrite oppR. Qed.

(** #  ROTMAN: Theorem 1(i)  # *)
Lemma mul0r : forall x : R, 0 * x = 0.
Proof. by move=> x; apply (@addr_injr (0 * x)); rewrite -distPM !add0r. Qed.

Lemma mulr0 : forall x : R, x * 0 = 0.
Proof. by move=> x; apply (@addr_injr (x * 0)); rewrite -distMP !add0r. Qed.

Lemma mul_oppL : forall x y : R, - x * y = - (x * y).
Proof. by move=> x y; apply (@opp_uniq (x * y));rewrite -?distPM oppR ?mul0r. Qed.

Lemma mul_oppR : forall x y : R, x * - y = - (x * y).
Proof. by move=> x y; apply (@opp_uniq (x * y)); rewrite -?distMP oppR ?mulr0. Qed.

Lemma mul_opp_opp : forall x y : R, - x * - y = x * y.
Proof. by move=> x y; rewrite mul_oppR mul_oppL opp_opp. Qed.

Lemma opp_sym : forall x y : R, - x = y -> x = - y.
Proof. by move=> x y H; rewrite -H; symmetry; exact: opp_opp. Qed.

Lemma addrCA : forall m n p : R, m + (n + p) = n + (m + p).
Proof. by move=> m n p; rewrite addA [m + _]addC addA. Qed.

Lemma opp0 : - 0 = 0 :> R.
Proof. by apply (@addr_injr 0); rewrite oppL !addr0. Qed.

Lemma oppr0 : forall x : R, (-x == 0) = (x == 0).
Proof.
 (* {{{ *)

move=> x.
apply/eqP.
case H : (_ == _) => [|H']; first by rewrite (eqP H) opp0.
move: (congr1 (@oppr _) H).
rewrite opp_opp opp0 => H0.
by rewrite H0 eq_refl in H'.

 (* }}} *)
Qed.

Lemma mul1r : forall x : R, 1 * x = x.
Proof. exact: mul1r' (axioms _). Qed.

Lemma mulr1 : forall x : R, x * 1 = x.
Proof. exact: mulr1' (axioms _). Qed.

(** #  ROTMAN: Theorem 1(ii)  # *)
Lemma mul_opp1r : forall x : R, -(1) * x = - x.
Proof. by move=> x; apply (@addr_injl x); rewrite oppR mul_oppL mul1r oppR. Qed.

(** #  ROTMAN: Theorem 1(iii)  # *)
Lemma mul_opp1_opp : forall x : R, -(1) * - x = x.
Proof. by move=> x; rewrite mul_opp1r opp_opp. Qed.

Lemma mul_opp1_opp1 : -(1) * -(1) = 1 :> R.
Proof.  exact: mul_opp1_opp. Qed.

Lemma opp_add : forall x y : R, -(x + y) = - x - y.
Proof. by move=> x y; rewrite -mul_opp1r distMP !mul_opp1r. Qed.

Lemma zero_ring : (1:R) = 0 -> forall x : R, x = 0.
Proof. by move=> H x; rewrite -[x]mul1r H mul0r. Qed.

Lemma subr0 : forall x : R, x - 0 = x.
Proof. by rewrite opp0; exact: addr0. Qed.

Lemma sub0r : forall x : R, 0 - x = - x.
Proof. by move=> x; rewrite add0r. Qed.

Lemma mulC : forall x y : R, x * y = y * x.
Proof. exact: mulC' (axioms _). Qed.

Lemma mulrCA : forall m n p : R, m * (n * p) = n * (m * p).
Proof. by move=> m n p; rewrite mulA [m * _]mulC mulA. Qed.

Definition rdivides a b := exists a' : R, a * a' = b.

Notation "x |` y" := (rdivides x y) (at level 55).

Lemma div0 : forall c : R, c |` 0.
Proof. exists (0:R); exact: mulr0. Qed.

Lemma div1 : forall c : R, 1 |` c.
Proof. by move=> c; exists c; rewrite mul1r. Qed.

Lemma div_refl : forall c : R, c |` c.
Proof. by move=> x; exists (1 : R); rewrite mulr1. Qed.

Lemma div_add : forall a b c : R, c |` a -> c |` b -> c |` a + b.
Proof.
 (* {{{ *)

move=> a b c [a' <-] [b' <-].
rewrite -distMP.
by exists (a' + b').

 (* }}} *)
Qed.

Lemma div_mulL : forall a b c : R, c |` a -> c |` a * b.
Proof. by move=> a b c [a' <-]; exists (a' * b); rewrite mulA. Qed.

Lemma div_trans : forall a b c : R, a |` b -> b |` c -> a |` c.
Proof. by move=> a b c [a' <-] [b' <-]; rewrite -mulA; exists (a' * b'). Qed.

Lemma div_mulR : forall a b c : R, c |` b -> c |` a * b.
Proof. by move=> a b c [b' <-]; exists (a * b'); rewrite mulC -mulA [b' * _]mulC. Qed.

Lemma div_addP : forall a b c : R, c |` a + b -> c |` a -> c |` b.
Proof.
 (* {{{ *)

move=> a b c [d Hd] [a' Ha'].
rewrite -Ha' in Hd.
move: (canLR Hd (addKr (c * a'))).
rewrite -mul_oppR -distMP.
by exists (- a' + d).

 (* }}} *)
Qed.

(** Definitions *)

CoInductive gcd (f g d : R) : Type :=
  Gcd : (d |` f) -> (d |` g) ->
       (forall d', (d' |` f) -> (d' |` g) -> (d' |` d)) -> gcd f g d.

Definition unit (x : R) := exists x', (x * x' = 1).

Lemma unit_nz : (1:R) <> 0 -> forall u, unit u -> u <> (0:R).
Proof. by move=> H u [u' Hu'] H'; rewrite H' mul0r in Hu'; move/esym: Hu'. Qed.

Definition associates x y := exists u : R, unit u /\ x = u * y.

Definition irreducible (p : R) := forall x y, x * y = p -> (unit x \/ unit y).

Definition prime (p : R) := ~ (unit p) /\ irreducible p.

Definition rel_prime x y := forall d : R, gcd x y d -> unit d.

Fixpoint pow (x : R) (n : nat) {struct n} : R :=
  if n is S n' then x * pow x n' else 1.

Fixpoint cmul (n : nat) (a : R) {struct n} : R :=
  if n is S n' then a + cmul n' a else 1.

Fixpoint dot (s1 s2 : seq R) {struct s1} : R :=
  match s1,s2 with
    | seq0, seq0 => 1%R
    | Adds h1 t1, Adds h2 t2 => h1 * h2 + dot t1 t2
    | _, _ => 0
  end.

Definition domainP := forall x1 x2 : R, x1 * x2 = 0 -> x1 = 0 \/ x2 = 0.

(** #  ROTMAN: Theorem 2 # *)
Lemma domain_cancel : (forall r a b : R, r != 0 -> r * a = r * b -> a = b) <-> domainP.
Proof.
 (* {{{ *)
split.
  move=> H x1 x2 H1.
  case H2 : (x1 == 0).
  left; by apply/eqP.
  right.
  move/negbT: H2.
  move/(H x1 x2 0).
  apply.
  by rewrite mulr0.
move=> H r a b H1 H2.
have: r * (a - b) = 0 by rewrite distMP mul_oppR H2 oppR.
move/(H _ _) => [].
  by move/eqP: H1.
move=> H3.
apply(@addr_injr (-b)).
by rewrite H3 oppR.
 (* }}} *)
Qed.

(** #  ROTMAN: Exercise 4 # *)
Lemma domain_unit : domainP -> forall f g u v : R, f <> 0 -> f = u * g -> g = v * f -> u * v = 1.
Proof.
 (* {{{ *)
move=> H f g u v Hf Hfg Hgf.
move: Hfg.
rewrite {}Hgf mulA -{1}(@mul1r f) => Hfg.
move: {Hfg}(comb (addrr (- (1 * f))) Hfg).
rewrite oppR -mul_oppL -distPM.
move=> Hg.
move: {Hg}(sym_eq Hg).
move/H.
move=> [] //.
move/(comb (addrr 1)).
by rewrite -addA oppL addr0 add0r.
 (* }}} *)
Qed.

End Rings.

Notation "x |` y" := (rdivides x y) (at level 55) : ring_scope.
Notation "x ^ n" := (pow x n) : ring_scope.

Prenex Implicits unit.

(* -------------------------------------------------------------------------- *)
(*  Integral domains                                                          *)
(* -------------------------------------------------------------------------- *)

(** Integral domains *)
Structure domain : Type := Idom {
  ibase :> ring;
  integ : domainP ibase
}.

Section Domain.

Variable R : domain.

Lemma mulr_injl : forall x : R, x <> 0 -> injective (mulr x).
Proof.
 (* {{{ *)
move=> x Hx y z Hxy.
rewrite -(add0r (x * z)) in Hxy.
move/(fun H => canLR H (addrK _)) : Hxy.
rewrite -mul_oppR -distMP.
move/integ => [|] //.
move/(fun H => canRL H (addrKV _)).
by rewrite add0r.
 (* }}} *)
Qed.

Lemma mulr_injr : forall z x y : R, z <> 0 -> (x * z = y * z) -> (x = y).
Proof. by move=> z x y H0 H; apply: (mulr_injl H0); rewrite mulC H mulC. Qed.
Open Scope ring_scope.

Lemma div_sym : forall a b : R, a |` b -> b |` a -> associates a b.
Proof.
 (* {{{ *)
move=> a b [a' Ha'] [b' Hb'].
case Ha : (a == 0); move/eqP: Ha => Ha.
  have Hb : (b = 0) by symmetry; rewrite Ha mul0r in Ha'.
  exists (1:R); split; first by exists (1:R); rewrite mulr1.
  by rewrite Ha Hb mulr0.
exists b'.
split.
  exists a'.
  rewrite -Ha' in Hb'.
  rewrite mulC.
  apply: (mulr_injl Ha).
  by rewrite mulA mulr1.
by rewrite -Hb' mulC.
 (* }}} *)
Qed.

End Domain.

(** Fields *)

Module Field.

Structure field : Type := Field {
  fbase :> domain;
  inv : fbase -> fbase;
  unitPL : forall x : fbase, x <> 0 -> inv x * x = 1;
  nzP : 1 <> 0 :> fbase;
  inv0 : inv 0 = 0
}.

End Field.

Notation field := Field.field (only parsing).
Arguments Scope Field.inv [_ ring_scope].

Definition invf := nosimpl Field.inv.

Notation "x '^-1'" := (invf x) (at level 9, format "x '^-1'") : ring_scope.

(** Euclidean rings *)

Open Scope nati_scope.
Open Scope ring_scope.

Inductive div_res (R : ring) (deg : R -> nati) (a b : R) : Prop :=
  Div_res q r : a = q * b + r -> deg r < deg b -> div_res deg a b.

Structure euclid_ring : Type := Ering {
  ebase :> domain;
  deg : ebase -> nati;
  deg0 : forall x, deg x = -oo -> x = 0;
  deg0' : forall x, x = 0 -> deg x = -oo;
  deg_lt : forall a b, b <> 0 -> deg a <= deg (a * b);
  degP : forall a b, b <> 0 -> div_res deg a b
}.

Section Fields.

Variable F : field.

Lemma inv0 : 0^-1 = 0 :> F.
Proof. exact: Field.inv0. Qed.

Lemma invL : forall x : F, x <> 0 -> x^-1 * x = 1.
Proof. exact: Field.unitPL. Qed.

Lemma mulKr : forall x : F, x <> 0 -> cancel (mulr x) (mulr x^-1).
Proof. by move=> x Hx y; rewrite mulA (invL Hx) mul1r. Qed.

Lemma invR : forall x : F, x <> 0 -> x * x^-1 = 1.
Proof. move=> x; rewrite mulC; exact: invL. Qed.

Lemma mulrK : forall x : F, x <> 0 -> cancel (mulrr x) (mulrr x^-1).
Proof. by move=> x Hx y; rewrite -mulA (invR Hx) mulr1. Qed.

Lemma mulKrV : forall x : F, x <> 0 -> cancel (mulr x^-1) (mulr x).
Proof. by move=> x Hx y; rewrite mulA (invR Hx) mul1r. Qed.

Lemma mulrKV : forall x : F, x <> 0 -> cancel (mulrr x^-1) (mulrr x).
Proof. by move=> x Hx y; rewrite -mulA (invL Hx) mulr1. Qed.

Lemma inv_injR : forall x y : F, x <> 0 -> x * y = 1 -> y = x^-1.
Proof.
 (* {{{ *)
move=> x y Hx.
move/(congr1 (fun k => x^-1 * k)).
by rewrite mulA invL // mul1r mulr1.
 (* }}} *)
Qed.

Lemma inv_injL : forall x y : F, x <> 0 -> y * x = 1 -> y = x^-1.
Proof.  move=> x y; rewrite mulC; exact: inv_injR. Qed.

Lemma nzP : 1 <> 0 :> F.
Proof. exact: Field.nzP. Qed.

Lemma opp1nz : -(1) != 0 :> F.
Proof.
 (* {{{ *)
apply/eqP.
move/(congr1 (fun x => x * -(1))).
rewrite mul_opp1_opp1 mul0r.
exact: nzP.
 (* }}} *)
Qed.

Lemma inv1 : 1^-1 = 1 :> F.
Proof. symmetry; apply: inv_injL; first exact: nzP; by rewrite mulr1. Qed.

Lemma opp_inv : forall x : F, x <> 0 -> (- x)^-1 = -(x ^-1).
Proof.
 (* {{{ *)
move=> x Hx.
symmetry.
apply: inv_injR.
  move=> H.
  by rewrite -(opp_opp x) H opp0 in Hx.
by rewrite mul_opp_opp invR.
 (* }}} *)
Qed.

Lemma add_inv0 : forall x y : F, x <> 0 -> y <> 0 -> x + y = 0 -> x ^-1 + y ^-1 = 0.
Proof.
 (* {{{ *)
move=> x y Hx Hy Hxy.
move/(congr1 (fun k => - x + k)): Hxy.
rewrite addA oppL addr0 add0r => ->.
rewrite opp_inv => //.
by rewrite oppR.
 (* }}} *)
Qed.

End Fields.

(** Subrings *)
Section Sub_ring.

Variable R : ring.

Structure subring : Type := Subring {
  srbase :> set R;
  zeroP : srbase 0;
  oneP : srbase 1;
  addP : forall x y : R, srbase x -> srbase y -> srbase (x + y);
  mulP : forall x y : R, srbase x -> srbase y -> srbase (x * y);
  oppP : forall x : R, srbase x -> srbase (- x)
}.

Lemma Subring_ext : forall H K : subring, srbase H = srbase K -> H = K.
Proof.
 (* {{{ *)
move=> [H1 H2 H3 H4 H5 H6] [K1 K2 K3 K4 K5 K6].
rewrite /= => H.
rewrite H in H2 H3 H4 H5 H6 *.
congr Subring;  by apply: proof_irrelevance.
 (* }}} *)
Qed.

Definition ring_to_subring : subring.
exists (fun (x:R) => true) => //.
Defined.

Variable S : subring.

Notation Sty := (sub_eqType S).

Definition sadd : Sty -> Sty -> Sty.
 (* {{{ *)
move=> x y.
exists (val x + val y).
abstract(apply: addP; exact: valP).
 (* }}} *)
Defined.

Definition smul : Sty -> Sty -> Sty.
 (* {{{ *)
move=> x y.
exists (val x * val y).
abstract(apply: mulP; exact: valP).
 (* }}} *)
Defined.

Definition sopp : Sty -> Sty.
 (* {{{ *)
move=> x.
exists (- val x).
abstract(apply: oppP; exact: valP).
 (* }}} *)
Defined.

Definition szero := EqSig _ 0 (@zeroP S).

Definition sone := EqSig _ 1 (@oneP S).

Lemma subring_axioms : ring_axioms sadd smul sopp szero sone.
Proof.
 (* {{{ *)

split; move=> H *; apply: val_inj => /=;
[exact: addC |
 exact: addA |
 exact: addr0 |
 exact: oppL |
 exact: mulA |
 exact: distPM |
 exact: distMP |
 exact: mul1r |
 exact: mulr1 |
 exact: mulC].

 (* }}} *)
Qed.

Definition subring_to_ring := Ring.Ring subring_axioms.

Lemma subring_addl : forall x y, S x -> S (x + y) -> S y.
Proof.
 (* {{{ *)
move=> x y Hx Hxy.
move: (oppP Hx) => Hx'.
move: (addP Hx' Hxy).
by rewrite addA oppL add0r.
 (* }}} *)
Qed.

Lemma subring_addr : forall x y, S y -> S (x + y) -> S x.
Proof. by move=> x y Hy; rewrite addC; apply: subring_addl. Qed.

Lemma subr_m1 : S (- (1:R)).
Proof. apply: oppP. exact: oneP. Qed.

End Sub_ring.

Coercion ring_to_subring : ring >-> subring.

(** Subdomain *)
Section SubDomain.

Variable R : domain.
Variable S : subring R.

Definition subring_to_domain : domain.
 (* {{{ *)

exists (subring_to_ring S).
abstract(
  move=> x1 x2 [H];
  (case: {H}(integ H) => H; first by (left; apply: val_inj));
  by right;apply: val_inj).

 (* }}} *)
Defined.

End SubDomain.

(** Subfields *)

Section Sub_field.

Variable F : field.

Structure subfield : Type := Subfield {
  sfbase :> subring F;
  invP : forall x : F, sfbase x -> sfbase (invf x)
}.

Lemma Subfield_ext : forall H K : subfield, srbase H = srbase K -> H = K.
Proof.
 (* {{{ *)
move=> [[H1 H2 H3 H4 H5] H6 H7] [[K1 K2 K3 K4 K5] K6 K7] /= H.
rewrite {H1} H in H2 H3 H4 H5 H6 H7 *.
have -> : H2 = K2 by apply: proof_irrelevance.
have -> : H3 = K3 by apply: proof_irrelevance.
have -> : H4 = K4 by apply: proof_irrelevance.
have -> : H5 = K5 by apply: proof_irrelevance.
have -> : H6 = K6 by apply: proof_irrelevance.
congr Subfield.
by apply: proof_irrelevance.
 (* }}} *)
Qed.

Definition field_to_subfield : subfield.
exists (ring_to_subring F) => //.
Defined.

Variable S : subfield.

Notation Fty := (sub_eqType S).

Definition sinv : Fty -> Fty.
 (* {{{ *)
move=> x.
exists ((val x)^-1).
abstract(apply: invP; exact: valP).
 (* }}} *)
Defined.

Definition subfield_to_field : field.
 (* {{{ *)
exists (subring_to_domain S) sinv.
  abstract(
  move=> [x Hx] H;
  apply: val_inj => /=;
  apply: invL => H0;
  rewrite H0 in Hx H;
  (suffices: (EqSig S 0 Hx = (@szero _ _)) by done);
  by apply: val_inj).
abstract(move=> [H]; by move/nzP: H).
abstract(
rewrite /sinv;
apply: val_inj => /=;
exact: inv0).
 (* }}} *)
Defined.

End Sub_field.

Coercion field_to_subfield : field >-> subfield.

(** Ideals *)

Section Ideal.

Variable U : ring.
Variable R : subring U.

Structure ideal : Type := Ideal {
  idbase :> set U;
  id_ss : sub_set idbase R;
  id0 : idbase 0;
  id_add : forall x y : U, idbase x -> idbase y -> idbase (x + y);
  idPL : forall x y : U, idbase x -> R y -> idbase (x * y);
  idPR : forall x y : U, R x -> idbase y -> idbase (x * y)
}.

Lemma id_opp : forall (I:ideal) x, I x -> I (- x).
Proof.  by move=> I x Hx; rewrite -mul_opp1r idPR // subr_m1. Qed.

Definition ring_to_ideal : ideal.
 (* {{{ *)
exists R => //.
- exact: zeroP.
- exact: addP.
- exact: mulP.
- exact: mulP.
 (* }}} *)
Defined.

End Ideal.

Coercion ring_to_ideal : subring >-> ideal.

Section Ideal0.

Variable U : ring.
Variable R : subring U.

Lemma ideq : forall (I J : ideal R), (forall x, I x = J x) -> I = J.
Proof.
 (* {{{ *)

move=> [I a1 a2 a3 a4 a5] [J b1 b2 b3 b4 b5] /= H.
rewrite (weak_ext H) in a1 a2 a3 a4 a5 *.
congr Ideal; by apply: proof_irrelevance.

 (* }}} *)
Qed.

Lemma idbase_inj : forall I J : ideal R, (idbase I = idbase J) -> I = J.
Proof.
 (* {{{ *)

move=> I J H.
apply: ideq.
by rewrite H.

 (* }}} *)
Qed.

Definition zero_ideal : ideal R.
 (* {{{ *)
exists (fun x => x == 0 :> U).
- abstract(
  move=> x;
  move/eqP => ->;
  exact: zeroP).
- abstract(exact: eq_refl).
- abstract(by move=> x y;do 2 move/eqP => ->; rewrite addr0).
- abstract(by move=> x y; move/eqP => ->; rewrite mul0r).
abstract(
move=> x y Hx;
move/eqP => ->;
by rewrite mulr0).
 (* }}} *)
Defined.

Definition maximal_ideal (I : ideal R) :=
  I <> R /\
  forall J : ideal R, sub_set I J -> J = I \/ J = R.

Inductive not_maximal_ideal (I : ideal R) : Prop :=
  | Not_maximal0 : I = R -> not_maximal_ideal I
  | Not_maximal1 (J : ideal R) :
    sub_set I J -> J <> I -> J <> R -> not_maximal_ideal I.

Lemma not_maximalP : forall I, ~ (maximal_ideal I) -> not_maximal_ideal I.
Proof.
 (* {{{ *)
move=> I.
move/not_and_or => [|].
  left; by apply: NNPP.
move/(not_all_ex_not _ (fun x => _)) => [K HK].
move: (imply_to_and _ _ HK) => [H1 H2].
move/not_or_and: H2 => [H2 H3].
by apply: (@Not_maximal1 I K).
 (* }}} *)
Qed.

End Ideal0.

Notation "0" := (zero_ideal _) : ideal_scope.
Delimit Scope ideal_scope with Id.

Section Ideal1.

Open Scope ring_scope.
Open Scope ideal_scope.

Variable U : ring.
Variable R : subring U.

Hint Resolve id0 id_add idPL idPR mulP oneP zeroP addP.

Definition ideal_of_elem (a : U) : ideal R.
 (* {{{ *)
move/(insub R)=> [[a Ha]|]; last exact: 0.
exists (fun x => Pb (exists x', R x' /\ x = x' * a )).
- abstract(
  move=> x /=;
  move/PbP => [y [Hy ->]];
  auto).
- abstract(by apply/PbP; exists (0:U)%R; rewrite mul0r; auto).
- abstract(move=> x y;move/PbP => [x' [Hx' ->]]; move/PbP => [y' [Hy' ->]];
  rewrite -distPM; apply/PbP; exists (x' + y'); auto).
- abstract(move=> x y; move/PbP => [x' [Hx' ->]] Hy; apply/PbP; exists (x' * y);
  rewrite -mulA [a * _]mulC mulA; auto).
abstract(move=> x y Hx; move/PbP => [x' [Hx' ->]]; apply/PbP; exists (x * x');
rewrite mulA; auto).
  (* }}} *)
Defined.

Definition srunit u := exists u', R u' /\ u * u' = 1.

Lemma ideal_unit : forall a, R a -> srunit a -> ideal_of_elem a = R.
Proof.
 (* {{{ *)
move=> a Ha [u' [Hu Hu']].
apply: ideq => x /=.
rewrite /ideal_of_elem /=.
case: insubP => [[_ _] /= _ ->|]; last by rewrite Ha.
apply/idP/idP.
  by move/PbP => [y [Hy ->]]; auto.
move=> H.
apply/PbP.
exists (u' * x).
split; auto.
rewrite -mulA mulrCA.
rewrite mulC in Hu'.
by rewrite Hu' mulr1.
 (* }}} *)
Qed.

Lemma unit_ideal : forall u, R u -> ideal_of_elem u = R -> srunit u.
Proof.
 (* {{{ *)

move=> u Hu.
move/(congr1 (fun x => idbase x (1:U))).
rewrite /ideal_of_elem /ring_to_ideal /=.
case: insubP => [[_ _] /= _ ->|].
  move/PbP.
  rewrite oneP => [[x' [Hx' Hx0]]].
  exists x'.
  by rewrite mulC; split.
by move/negP.

 (* }}} *)
Qed.

End Ideal1.

Prenex Implicits ideal_of_elem.

(** Homomorphisms *)

Section Homo.

Variable R S : ring.
Variable R' : subring R.
Variable S' : subring S.

Structure homo (h : R -> S) : Prop := Homo {
  homoP : forall x, R' x -> S' (h x);
  homoAddP : forall x y, R' x -> R' y -> h (x + y) = h x + h y;
  homoMulP : forall x y, R' x -> R' y -> h (x * y) = h x * h y;
  homoJunk : forall x, ~ (R' x) -> h x = 0
}.

Structure iso (h : R -> S) : Prop := Iso {
  isobase :> homo h;
  imonoP : forall x y, R' x -> R' y -> h x = h y -> x = y;
  iontoP : surj R' S' h
}.

Definition isomorphic := exists h, iso h.

End Homo.

Definition endo R R' := @homo R R R' R'.
Definition auto R R' := @iso R R R' R'.

Prenex Implicits auto.

Section Homo0.

Variable R S : ring.
Variable R' : subring R.
Variable S' : subring S.
Variable s : R -> S.

Lemma homo0 : homo R' S' s -> s 0 = 0.
Proof.
 (* {{{ *)

move=> Hs.
apply: (@addr_injl _ (s 0)).
rewrite addr0 -(homoAddP Hs); try exact: zeroP.
by rewrite addr0.

 (* }}} *)
Qed.

Lemma homoOpp : homo R' S' s -> forall x, R' x -> s (- x) = - (s x).
Proof.
 (* {{{ *)
move=> Hs x Hx.
apply: (@addr_injl _ (s x)).
rewrite oppR -(homoAddP Hs) //.
  by rewrite oppR homo0.
exact: oppP.
 (* }}} *)
Qed.

Definition kernel := fun x => R' x && (s x == 0).

Definition ker_ideal : homo R' S' s -> ideal R'.
 (* {{{ *)

move=> Hs.
exists kernel.
- abstract(by move=> x; move/andP; firstorder).
- by rewrite /kernel homo0 // eq_refl andbT zeroP.
- abstract(
  move: (Hs) => [H1 H2 H3 H4];
  move=> x y;
  move/andP => [H5 H6];
  move/eqP: H6 => H6;
  move/andP => [H7 H8];
  move/eqP: H8 => H8;
  by rewrite /kernel H2 //= H6 H8 addr0 addP /=).
- abstract(
  move: (Hs) => [H1 H2 H3 H4];
  move=> x y;
  move/andP => [H5 H6];
  move/eqP: H6 => H6;
  move=> H7;
  by rewrite /kernel H3 //= H6 mulP //= mul0r).
- move: (Hs) => [H1 H2 H3 H4].
  move=> x y Hx.
  move/andP => [H5 H6].
  move/eqP: H6 => H6.
  rewrite /kernel.
  by rewrite mulP //= H3 //= H6 mulr0.

 (* }}} *)
Defined.

End Homo0.

Prenex Implicits kernel.

(** Isomorphisms *)

Section Iso.

Variable R S : ring.
Variable R' : subring R.
Variable S' : subring S.
Variable i : R -> S.
Hypothesis Hi : iso R' S' i.

(* -------------------------------  inverse  -------------------------------- *)

Structure iso_inv_spec (i' : S -> R) : Prop := IIS {
  ii_closed : forall x, S' x -> R' (i' x);
  ii_inv1 : forall x, R' x -> i' (i x) = x;
  ii_inv2 : forall y, S' y -> i (i' y) = y;
  ii_junk : forall y, ~ (S' y) -> i' y = 0
}.

Definition iso_inv y := if S' y then epsilon (inhabits 0) (fun x : R => R' x /\ i x = y) else 0.

Lemma iso_invP : iso_inv_spec iso_inv.
Proof.
 (* {{{ *)
split.
- move=> x Hx; rewrite /iso_inv.
  case H : (S' x).
    move: (@epsilon_spec _ (inhabits 0) (fun y => R' y /\ i y = x)).
    apply: antsE.
      move: (iontoP Hi Hx) => [y [Hy Hy']].
      by exists y; split.
    by move => [H1 H2].
  exact: zeroP.
- move=> x Hx; rewrite /iso_inv.
  have ->: (S' (i x)) by apply: (homoP Hi) ;eauto.
  move: (@epsilon_spec _ (inhabits 0) (fun y => R' y /\ i y = i x)).
  apply: antsE; first by exists x;split.
  move => [H1 H2].
  by move: (imonoP Hi H1 Hx H2) => ->.
- move=> y Hy; rewrite /iso_inv Hy.
  move: (@epsilon_spec _ (inhabits 0) (fun x => R' x /\ i x = y)).
  apply: antsE.
    move: (iontoP Hi Hy) => [y1 [Hy1 Hy1']].
    by exists y1; split.
  by move => [H1 H2].
by rewrite /iso_inv; move=> y Hy; move/eqP: Hy; rewrite neq_true; move/eqP => ->.
 (* }}} *)
Qed.

Hint Resolve oneP addP mulP oppP homoP homoAddP homoMulP ii_closed.

Lemma iso_inv_homo : homo S' R' iso_inv.
Proof.
 (* {{{ *)
move: iso_invP => [H1 H2 H3 H4].
split; auto.
- move=> x y Hx Hy.
  apply: (imonoP Hi); auto.
  rewrite H3;auto.
  rewrite (homoAddP Hi);auto.
  by rewrite !H3; auto.
- move=> x y Hx Hy.
  apply: (imonoP Hi); auto.
  rewrite H3;auto.
  rewrite (homoMulP Hi);auto.
  by rewrite !H3; auto.
 (* }}} *)
Qed.

Lemma iso_inv_iso : iso S' R' iso_inv.
Proof.
 (* {{{ *)
move: iso_invP => [H1 H2 H3 H4].
split; first by exact: iso_inv_homo.
  move=> x y Hx Hy.
  move/(congr1 i).
  by rewrite !H3;auto.
move=> y Hy.
exists (i y).
split.
  by apply: (homoP Hi).
by symmetry; auto.
 (* }}} *)
Qed.

Lemma iso1 : i 1 = 1.
Proof.
 (* {{{ *)
rewrite -(mul1r (i 1)).
rewrite -{1}(@ii_inv2 _ iso_invP 1);auto.
rewrite -(homoMulP Hi); auto.
  by rewrite mulr1 (ii_inv2 iso_invP); auto.
by apply: (ii_closed iso_invP); auto.
 (* }}} *)
Qed.

End Iso.

Section Iso0.

Variable F K : field.
Variable F' : subfield F.
Variable K' : subfield K.
Variable i : F -> K.
Hypothesis Hi : iso F' K' i.

Lemma inv_iso : forall x, F' x -> x <> 0 -> i (x^-1) = (i x)^-1.
Proof.
 (* {{{ *)
move=> x Hx H0.
have H0' : i x <> 0.
  move/(congr1 (iso_inv F' K' i)).
  rewrite (ii_inv1 (iso_invP Hi)); auto.
  by rewrite (homo0 (iso_inv_homo Hi)).
apply: (@mulr_injl _ (i x)) => //.
rewrite invR; auto.
rewrite -(homoMulP Hi); auto.
  rewrite invR;auto.
  exact: (iso1 Hi).
by apply: invP.
 (* }}} *)
Qed.

End Iso0.

Section Iso1.

Variable R S : ring.
Variable R' : subring R.
Variable S' : subring S.
Variable phi : R -> S.
Hypothesis phiP : homo R' S' phi.
Hypothesis ontoP : surj R' S' phi.
Hypothesis phiP' : kernel R' phi = set1 0.

Hint Resolve oppP addP.

Lemma homo_iso : iso R' S' phi.
Proof.
 (* {{{ *)

split => //.
move=> x y Hx Hy.
move/(congr1 (addrr (- phi y))).
rewrite oppR -(homoOpp phiP Hy) -(homoAddP phiP); auto.
move=> H.
move/(congr1 (fun f => f (x - y))): phiP'.
rewrite /kernel.
move/andP.
case H' : (_ == _).
  move=> _.
  move/eqP: H'.
  move/(congr1 (addrr y)).
  rewrite -addA oppL addr0 add0r.
  by move=> ->.
rewrite H.
move/not_and_or => [|].
  case; auto.
by rewrite eq_refl; move/negP.

 (* }}} *)
Qed.

End Iso1.


Require Import Coq.Bool.Bool.

Ltac reduce_orb_step :=
  match goal with
  | [ |- context [?X || ?Y || (?Z || ?Y)]] =>
    rewrite orb_comm with Z Y
  | [ |- context [?X || ?Y || (?Y || ?Z)]] =>
    rewrite orb_assoc with (X||Y) Y Z
  | [ |- context [?X || ?Y || ?Y]] =>
    rewrite <- orb_assoc with X Y Y
  | [ |- context [?Y || ?Y]] =>
    rewrite orb_diag
  | [|- context [?X || ?Y || ?Z = ?X || ?Z || ?Y]] =>
    rewrite <- orb_assoc with X Z Y;
    rewrite orb_comm with Z Y;
    rewrite orb_assoc with X Y Z
  end.

Ltac reduce_orb := repeat (try reduce_orb_step).

Example example_reduce_orb_step: forall (a b c: bool),
  a || b || (c || b) = a || b || c.
Proof.
intros.
reduce_orb_step.
reduce_orb_step.
reduce_orb_step.
reduce_orb_step.
reflexivity.
Qed.

Example example_reduce_orb: forall (a b c: bool),
  a || b || (c || b) = a || b || c.
Proof.
intros.
reduce_orb.
reflexivity.
Qed.

(* TODO: Good First Issue
   Add more examples of using reduce_orb_step,
   by creating theorems that are proved using reduce_orb_step
   The theorem names should start with example_
*)


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype finfun bigop prime binomial ssralg.
From mathcomp Require Import finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import Reals_ext ssrR logb Rbigop proba channel.

(** * Definition of a channel code *)

Reserved Notation "e( W , c )" (at level 50).
Reserved Notation "echa( W , c )" (at level 50).

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope proba_scope.
Local Open Scope channel_scope.

Section code_definition.

(** A code is an index set
   (or set of codewords) M with an encoding and a decoding function. *)

Variables A B M : finType.
Variable n : nat.

Local Open Scope ring_scope.

Definition encT := {ffun M -> 'rV[A]_n}.
Definition decT := {ffun 'rV[B]_n -> option M}.

Record code := mkCode { enc : encT ; dec : decT }.

Definition CodeRate (c : code) := (log (INR #| M |) / INR n)%R.

(** Probability of error given that the codeword m was sent: *)

Definition preimC (phi : decT) m := ~: (phi @^-1: xpred1 (Some m)).

Definition ErrRateCond (W : `Ch_1(A, B)) c m :=
  Pr (W ``(| enc c m)) (preimC (dec c) m).

Local Notation "e( W , c )" := (ErrRateCond W c) (at level 50).

(** Average probability of error: *)

Definition CodeErrRate (W : `Ch_1(A, B)) c :=
  (1 / INR #| M | * \rsum_(m in M) e(W, c) m)%R.

Local Notation "echa( W , c )" := (CodeErrRate W c) (at level 50).

Lemma echa_ge0 (HM : (0 < #| M |)%nat) W (c : code) : 0 <= echa(W , c).
Proof.
apply mulR_ge0.
- apply divR_ge0; by [fourier | exact/ltR0n].
- apply: rsumr_ge0 => ? _; apply: rsumr_ge0 => ? _; exact: DMC_ge0.
Qed.

Lemma echa1 (HM : (0 < #| M |)%nat) W (c : code) : echa(W , c) <= 1.
Proof.
rewrite /CodeErrRate div1R.
apply (@leR_pmul2l (INR #|M|)); first exact/ltR0n.
rewrite mulRA mulRV ?INR_eq0' -?lt0n // mul1R -iter_addR -big_const.
apply: ler_rsum => m _; exact: Pr_1.
Qed.

End code_definition.

Notation "e( W , c )" := (ErrRateCond W c) : channel_code_scope.
Notation "echa( W , c )" := (CodeErrRate W c) : channel_code_scope.

(** Definition of the set of (code) rates (unit: bits per transmission): *)

Record CodeRateType := mkCodeRateType {
  rate :> R ;
  _ : exists n d, (0 < n)%nat /\ (0 < d)%nat /\ rate = log (INR n) / INR d }.


Require Import Classical.

Inductive Ordinal : Type :=
  | ordS : Ordinal -> Ordinal
  | ord_sup: forall {I:Type}, (I->Ordinal) -> Ordinal.

(*
Fixpoint ord_le (alpha beta:Ordinal) : Prop :=
  match alpha with
  | ordS alpha =>
                  (fix gt_alpha (beta:Ordinal) : Prop :=
                  match beta with
                  | ordS beta => ord_le alpha beta
                  | ord_sup J beta => exists j:J,
                    gt_alpha (beta j)
                  end) beta
  | ord_sup I0 alpha => forall i:I0, ord_le (alpha i) beta
  end.
*)

Inductive ord_le : Ordinal -> Ordinal -> Prop :=
  | ord_le_respects_succ: forall alpha beta:Ordinal,
    ord_le alpha beta -> ord_le (ordS alpha) (ordS beta)
  | ord_le_S_sup: forall (alpha:Ordinal) (J:Type)
    (beta:J->Ordinal) (j:J), ord_le (ordS alpha) (beta j) ->
    ord_le (ordS alpha) (ord_sup beta)
  | ord_sup_minimal: forall (I:Type) (alpha:I->Ordinal)
    (beta:Ordinal), (forall i:I, ord_le (alpha i) beta) ->
                    ord_le (ord_sup alpha) beta.

Definition ord_lt (alpha beta:Ordinal) :=
  ord_le (ordS alpha) beta.
Definition ord_eq (alpha beta:Ordinal) :=
  ord_le alpha beta /\ ord_le beta alpha.
Definition ord_ge (alpha beta:Ordinal) :=
  ord_le beta alpha.
Definition ord_gt (alpha beta:Ordinal) :=
  ord_lt beta alpha.

Delimit Scope ordinal_scope with Ordinal.
Open Scope ordinal_scope.
Notation "alpha < beta" := (ord_lt alpha beta) : ordinal_scope.
Notation "alpha <= beta" := (ord_le alpha beta) : ordinal_scope.
Notation "alpha == beta" := (ord_eq alpha beta)
  (at level 70) : ordinal_scope.
Notation "alpha > beta" := (ord_gt alpha beta) : ordinal_scope.
Notation "alpha >= beta" := (ord_ge alpha beta) : ordinal_scope.

Lemma ord_le_respects_succ_converse: forall alpha beta:Ordinal,
  ordS alpha <= ordS beta -> alpha <= beta.
Proof.
intros.
inversion_clear H.
assumption.
Qed.

Lemma ord_le_S_sup_converse: forall (alpha:Ordinal)
  (J:Type) (beta:J->Ordinal), ordS alpha <= ord_sup beta ->
  exists j:J, ordS alpha <= beta j.
Proof.
intros.
inversion H.
exists j.
assumption.
Qed.

Lemma ord_sup_minimal_converse: forall (I:Type)
  (alpha:I->Ordinal) (beta:Ordinal),
  ord_sup alpha <= beta -> forall i:I, alpha i <= beta.
Proof.
intros.
inversion H.
Require Import Eqdep.
apply inj_pair2 in H2.
destruct H2.
apply H3.
Qed.

Lemma ord_le_trans: forall alpha beta gamma:Ordinal,
  alpha <= beta -> beta <= gamma -> alpha <= gamma.
Proof.
induction alpha.
induction beta.
induction gamma.
intros.
apply ord_le_respects_succ.
apply IHalpha with beta.
apply ord_le_respects_succ_converse; trivial.
apply ord_le_respects_succ_converse; trivial.
intros.
apply ord_le_S_sup_converse in H1.
destruct H1 as [i].
apply ord_le_S_sup with i.
apply H; trivial.
intros.
pose proof (ord_sup_minimal_converse _ _ _ H1).
apply ord_le_S_sup_converse in H0.
destruct H0 as [i].
apply H with i; trivial.
intros.
pose proof (ord_sup_minimal_converse _ _ _ H0).
constructor.
intro.
apply H with beta; trivial.
Qed.

Lemma ord_le_sup: forall (I:Type) (alpha:I->Ordinal) (i:I),
  alpha i <= ord_sup alpha.
Proof.
assert (forall beta:Ordinal, beta <= beta /\
  forall (I:Type) (alpha:I->Ordinal) (i:I),
  beta <= alpha i -> beta <= ord_sup alpha).
induction beta.
destruct IHbeta.
split.
apply ord_le_respects_succ; trivial.
intros.
apply ord_le_S_sup with i.
trivial.
split.
apply ord_sup_minimal.
intro.
destruct (H i).
apply H1 with i; trivial.
intros J alpha j ?.
apply ord_sup_minimal.
intro.
destruct (H i).
apply H2 with j.
apply ord_le_trans with (ord_sup o).
apply H2 with i; trivial.
trivial.

intros.
destruct (H (alpha i)).
apply H1 with i; trivial.
Qed.

Lemma ord_le_refl: forall alpha:Ordinal, alpha <= alpha.
Proof.
induction alpha.
apply ord_le_respects_succ; trivial.
apply ord_sup_minimal.
apply ord_le_sup.
Qed.

Lemma ord_le_S: forall alpha:Ordinal, alpha <= ordS alpha.
Proof.
induction alpha.
apply ord_le_respects_succ; trivial.
apply ord_sup_minimal.
intro.
apply ord_le_trans with (ordS (o i)).
apply H.
apply ord_le_respects_succ.
apply ord_le_sup.
Qed.

Lemma ord_lt_le: forall alpha beta:Ordinal,
  alpha < beta -> alpha <= beta.
Proof.
intros.
apply ord_le_trans with (ordS alpha); trivial.
apply ord_le_S.
Qed.

Lemma ord_lt_le_trans: forall alpha beta gamma:Ordinal,
  alpha < beta -> beta <= gamma -> alpha < gamma.
Proof.
intros.
apply ord_le_trans with beta; trivial.
Qed.

Lemma ord_le_lt_trans: forall alpha beta gamma:Ordinal,
  alpha <= beta -> beta < gamma -> alpha < gamma.
Proof.
intros.
apply ord_le_trans with (ordS beta); trivial.
apply ord_le_respects_succ; trivial.
Qed.

Lemma ord_lt_trans: forall alpha beta gamma:Ordinal,
  alpha < beta -> beta < gamma -> alpha < gamma.
Proof.
intros.
apply ord_lt_le_trans with beta; trivial;
 apply ord_lt_le; trivial.
Qed.

Lemma ord_lt_respects_succ: forall alpha beta:Ordinal,
  alpha < beta -> ordS alpha < ordS beta.
Proof.
intros.
apply ord_le_respects_succ; trivial.
Qed.

Lemma ord_total_order: forall alpha beta:Ordinal,
  alpha < beta \/ alpha == beta \/ alpha > beta.
Proof.
induction alpha.
induction beta.
destruct (IHalpha beta) as [|[|]].
left; apply ord_lt_respects_succ; trivial.
right; left.
split.
apply ord_le_respects_succ; apply H.
apply ord_le_respects_succ; apply H.
right; right.
apply ord_lt_respects_succ; trivial.

destruct (classic (exists i:I, ordS alpha < o i)).
destruct H0 as [i].
left.
apply ord_lt_le_trans with (o i); trivial.
apply ord_le_sup.
destruct (classic (exists i:I, ordS alpha == o i)).
destruct H1 as [i].
right; left.
split.
apply ord_le_trans with (o i).
apply H1.
apply ord_le_sup.
apply ord_sup_minimal.
intro.
destruct (H i0) as [|[|]].
contradiction H0; exists i0; trivial.
apply H2.
apply ord_lt_le; trivial.
assert (forall i:I, ordS alpha > o i).
intros.
destruct (H i) as [|[|]].
contradiction H0; exists i; trivial.
contradiction H1; exists i; trivial.
trivial.
right; right.
apply ord_le_lt_trans with alpha.
apply ord_sup_minimal.
intro.
apply ord_le_respects_succ_converse.
apply H2.
apply ord_le_refl.

induction beta.
case (classic (exists i:I, o i > ordS beta)); intro.
destruct H0 as [i].
right; right.
apply ord_lt_le_trans with (o i); trivial.
apply ord_le_sup.
case (classic (exists i:I, o i == ordS beta)); intro.
right; left.
destruct H1 as [i].
split.
apply ord_sup_minimal.
intro j.
destruct (H j (ordS beta)) as [|[|]].
apply ord_lt_le; trivial.
apply H2.
contradiction H0; exists j; trivial.
apply ord_le_trans with (o i).
apply H1.
apply ord_le_sup.
left.
apply ord_le_respects_succ.
apply ord_sup_minimal.
intro.
destruct (H i (ordS beta)) as [|[|]].
apply ord_le_respects_succ_converse; trivial.
contradiction H1; exists i; trivial.
contradiction H0; exists i; trivial.

case (classic (exists j:I0, ord_sup o < o0 j)); intro.
left.
destruct H1 as [j].
apply ord_lt_le_trans with (o0 j); trivial.
apply ord_le_sup.
case (classic (exists i:I, o i > ord_sup o0)); intro.
destruct H2 as [i].
right; right.
apply ord_lt_le_trans with (o i); trivial.
apply ord_le_sup.

right; left.
split.
apply ord_sup_minimal; intro.
destruct (H i (ord_sup o0)) as [|[|]].
apply ord_lt_le; trivial.
apply H3.
contradiction H2; exists i; trivial.
apply ord_sup_minimal; intro j.
destruct (H0 j) as [|[|]].
contradiction H1; exists j; trivial.
apply H3.
apply ord_lt_le; trivial.
Qed.

Lemma ordinals_well_founded: well_founded ord_lt.
Proof.
red; intro alpha.
induction alpha.
constructor.
intros beta ?.
apply ord_le_respects_succ_converse in H.
constructor; intros gamma ?.
destruct IHalpha.
apply H1.
apply ord_lt_le_trans with beta; trivial.

constructor; intros alpha ?.
apply ord_le_S_sup_converse in H0.
destruct H0 as [j].

destruct (H j).
apply H1; trivial.
Qed.

Lemma ord_lt_irrefl: forall alpha:Ordinal, ~(alpha < alpha).
Proof.
intro; red; intro.
assert (forall beta:Ordinal, beta <> alpha).
intro.
pose proof (ordinals_well_founded beta).
induction H0.
red; intro.
symmetry in H2; destruct H2.
contradiction (H1 alpha H); trivial.
contradiction (H0 alpha); trivial.
Qed.

Inductive successor_ordinal : Ordinal->Prop :=
  | intro_succ_ord: forall alpha:Ordinal,
    successor_ordinal (ordS alpha)
  | succ_ord_wd: forall alpha beta:Ordinal,
    successor_ordinal alpha -> alpha == beta ->
    successor_ordinal beta.
Inductive limit_ordinal : Ordinal->Prop :=
  | intro_limit_ord: forall {I:Type} (alpha:I->Ordinal),
    (forall i:I, exists j:I, alpha i < alpha j) ->
    limit_ordinal (ord_sup alpha)
  | limit_ord_wd: forall alpha beta:Ordinal,
    limit_ordinal alpha -> alpha == beta ->
    limit_ordinal beta.

Lemma ord_successor_or_limit: forall alpha:Ordinal,
  successor_ordinal alpha \/ limit_ordinal alpha.
Proof.
induction alpha.
left; constructor.
destruct (classic (forall i:I, exists j:I, o i < o j)).
right; constructor; trivial.
destruct (not_all_ex_not _ _ H0) as [i].
assert (forall j:I, o j <= o i).
intro.
destruct (ord_total_order (o i) (o j)) as [|[|]].
contradiction H1; exists j; trivial.
apply H2.
apply ord_lt_le; trivial.

assert (ord_sup o == o i).
split.
apply ord_sup_minimal; trivial.
apply ord_le_sup.
case (H i); intro.
left; apply succ_ord_wd with (o i); trivial.
split; apply H3.
right.
apply limit_ord_wd with (o i); trivial.
split; apply H3.
Qed.

Lemma successor_ordinal_not_limit: forall alpha:Ordinal,
  successor_ordinal alpha -> ~ limit_ordinal alpha.
Proof.
intros; red; intro.
induction H.
inversion_clear H0.
induction H as [I beta|].
assert (ord_sup beta <= alpha).
apply ord_sup_minimal.
intro.
apply ord_le_respects_succ_converse.
destruct (H i) as [j].
apply ord_le_trans with (beta j); trivial.
apply ord_le_trans with (ord_sup beta).
apply ord_le_sup.
apply H1.

contradiction (ord_lt_irrefl alpha).
apply ord_le_trans with (ord_sup beta); trivial.
apply H1.

apply IHlimit_ordinal.
split; apply ord_le_trans with beta;
  (apply H0 || apply H1).

contradiction IHsuccessor_ordinal.
apply limit_ord_wd with beta; trivial.
split; apply H1.
Qed.