(* Definitions and properties of rounding modes for binary floats. *)

(* We start with the round_toward_negative (rtn) rounding mode.  Given a
   rational number x, we'll construct the closest binary float (at precision p)
   that doesn't exceed x.

   We'll construct the float by giving its significand and exponent.  To do
   that, we'll need a lemma that the significand is bounded. *)

Require Import Qabs.

Require Import remedial.
Require Import rearrange_tactic.
Require Import is_integer.
Require Import floor_and_ceiling.
Require Import round.
Require Import twopower.
Require Import twopower_tactics.
Require Import binade.
Require Import binary_float.
Require Import next_up.

Local Open Scope Q.

(* There are two cases: x is zero, or x is nonzero. Let's first assume that x
   is nonzero. Then we can construct the significand and exponent directly. *)

Section RoundingForNonzero.

  Variable p : positive.
  Variable x : Q.
  Hypothesis x_nonzero : ~(x == 0).

  Let exponent : Z := (binadeQ x x_nonzero - (' p) + 1)%Z.
  Let scale : Q := twopowerQ exponent.

  Lemma _rtn_significand_bound :
    Qabs (inject_Z (floor (x / scale))) <= twopowerQ (' p).
  Proof.
    apply Qabs_floor_le; [now apply is_integer_twopowerQ |];
    subst scale exponent; twopower_right;
    apply Qlt_le_weak; apply (twopowerQ_binadeQ_lt _ _ x_nonzero); omega.
  Qed.

  Lemma _rtp_significand_bound :
    Qabs (inject_Z (ceiling (x / scale))) <= twopowerQ (' p).
  Proof.
    apply Qabs_ceiling_le; [now apply is_integer_twopowerQ |];
    subst scale exponent; twopower_right;
    apply Qlt_le_weak; apply (twopowerQ_binadeQ_lt _ _ x_nonzero); omega.
  Qed.

  Lemma _rte_significand_bound :
    Qabs (inject_Z (round (x / scale))) <= twopowerQ (' p).
  Proof.
    apply Qabs_round_le; [now apply is_integer_twopowerQ | ];
    subst scale exponent; twopower_right;
    apply Qlt_le_weak; apply (twopowerQ_binadeQ_lt _ _ x_nonzero); omega.
  Qed.

End RoundingForNonzero.

Definition round_toward_negative p x : binary_float p :=
  match Qeq_dec x 0 with
  | left x_zero => zero_float p
  | right x_nonzero =>
      let exponent := (binadeQ x x_nonzero - (' p) + 1)%Z in
      let scale : Q := twopowerQ exponent in
      let significand := floor (x / scale) in
      float_from_significand_and_exponent p significand exponent (
                                            _rtn_significand_bound _ _ _)
  end.

Definition round_toward_positive p x : binary_float p :=
  match Qeq_dec x 0 with
  | left x_zero => zero_float p
  | right x_nonzero =>
      let exponent := (binadeQ x x_nonzero - (' p) + 1)%Z in
      let scale : Q := twopowerQ exponent in
      let significand := ceiling (x / scale) in
      float_from_significand_and_exponent p significand exponent (
                                            _rtp_significand_bound _ _ _)
  end.

Definition round_ties_to_even p x : binary_float p :=
  match Qeq_dec x 0 with
  | left x_zero => zero_float p
  | right x_nonzero =>
      let exponent := (binadeQ x x_nonzero - (' p) + 1)%Z in
      let scale : Q := twopowerQ exponent in
      let significand := round (x / scale) in
      float_from_significand_and_exponent p significand exponent (
                                            _rte_significand_bound _ _ _)
  end.

Lemma round_toward_negative_spec (p : positive) (x : Q) (f : binary_float p) :
  proj1_sig f <= x   <->  (f <= round_toward_negative p x)%float.
Proof.
  (* Destruct to split into four subgoals. *)
  unfold round_toward_negative, float_le;
  destruct (Qeq_dec x 0) as [x_zero | x_nonzero]; [now rewrite x_zero | ];
  simpl; split; intro H.
  - (* Case x != 0, showing that f <= x -> f <= round x. *)
    twopower_left.
    case (Qle_ge_cases 0 x); intro.
    + (* Case 0 <= x.  Divide further depending on
         whether 2^(binade x) <= f or not. *)
      case (Qle_ge_cases (twopowerQ (binadeQ x x_nonzero)) (proj1_sig f));
      intro.
      * (* Case 2^(binade x) <= f.  Then we should be able to show
           that f is an integer. *)
        apply floorQ_intro.
        {
          apply (large_representable_is_integer p).
          - apply scaled_representable_is_representable_div; now destruct f.
          - match goal with
            | [ |- _ <= Qabs ?q ] => apply Qle_trans with (2 := Qle_Qabs _)
            end; now twopower_left.
        }
        {
          (* More twopower simplification. *)
          now twopower_left.
        }
      * (* Case f <= 2^(binade x).  Then we can apply transitivity. *)
        apply Qle_trans with (y := twopowerQ ('p - 1)).
        {
          now twopower_right.
        }
        {
          apply floorQ_intro.
          - apply is_integer_twopowerQ; assert (0 < 'p)%Z by easy; omega.
          - twopower_left;
            setoid_replace x with (Qabs x) at 2 by (symmetry; now apply Qabs_pos);
            apply (twopowerQ_binadeQ_le _ _ x_nonzero); apply Z.le_refl.
        }
    + (* Case x <= 0. *)
      apply floorQ_intro.
      * (* x <= 0, showing f / 2^(e-p+1) is an integer *)
        apply (large_representable_is_integer p).
        {
          (* Showing that f / 2^(e-p+1) is representable *)
          apply scaled_representable_is_representable_div; now destruct f.
        }
        {
          (* Showing that 2^(p-1) <= |f / 2^(e-p+1)| *)
          match goal with
          | [ |- _ <= Qabs ?q ] => apply Qle_trans with (2 := Qle_Qabs_neg _)
          end.
          apply Qle_trans with
          (y := - (x / twopowerQ (binadeQ x x_nonzero - ' p + 1))).
          - (* Showing that 2^(p-1) <= -(x/2^(e-p+1)) *)
            twopower_left.
            setoid_replace (-x) with (Qabs x) by (symmetry; now apply Qabs_neg);
            apply (twopowerQ_binadeQ_le _ _ x_nonzero); apply Z.le_refl.
          - (* Showing that -x/2^(e-p+1) <= -f/2^(e-p+1) *)
            rewrite <- Qopp_le_mono; now twopower_left.
        }
      * (* Showing that f / 2^(e-p+1) <= x / 2^(e-p+1) (again!) *)
        now twopower_left.
  - (* Showing that f <= round x -> f <= x. *)
    apply Qle_trans with (1 := H); twopower_right; apply floor_spec;
    apply Z.le_refl.
Qed.

(* With the specification in place, it's straightforward to prove some
   of the basic properties of round_toward_negative. *)

Add Parametric Morphism (p : positive) : (round_toward_negative p) with
    signature Qeq ==> (@float_eq p) as round_toward_negative_morphism.
Proof.
  intros x y x_eq_y; apply float_le_antisymm;
  rewrite <- round_toward_negative_spec;
  [ rewrite <- x_eq_y | rewrite x_eq_y ];
  apply round_toward_negative_spec; apply float_le_refl.
Qed.

Add Parametric Morphism (p : positive) : (round_toward_positive p)
    with signature Qeq ==> (@float_eq p) as round_toward_positive_morphism.
Proof.
  intros; unfold round_toward_positive, float_eq;
  destruct (Qeq_dec x 0), (Qeq_dec y 0).
  - easy.
  - contradict n. now rewrite <- H.
  - contradict n. now rewrite H.
  - simpl.
    assert (binadeQ y n0 = binadeQ x n)%Z by (now apply binadeQ_equiv).
    rewrite H0.
    now setoid_rewrite <- H.
Qed.

Add Parametric Morphism p : (round_ties_to_even p)
    with signature Qeq ==> float_eq (p := p) as round_ties_to_even_morphism.
Proof.
  intros x y H; unfold round_ties_to_even, float_eq;
  destruct (Qeq_dec x 0), (Qeq_dec y 0).
  - easy.
  - contradict n. now rewrite <- H.
  - contradict n. now rewrite H.
  - simpl.
    assert (binadeQ y n0 = binadeQ x n)%Z by (now apply binadeQ_equiv).
    rewrite H0.
    now setoid_rewrite <- H.
Qed.

Lemma round_toward_negative_monotonic (p : positive) x y :
  x <= y  ->  (round_toward_negative p x <= round_toward_negative p y)%float.
Proof.
  intro. rewrite <- round_toward_negative_spec.
  apply Qle_trans with (y := x).
  apply round_toward_negative_spec. apply float_le_refl. easy.
Qed.

Lemma round_toward_negative_id (p : positive) x :
  representable p x  <->  proj1_sig (round_toward_negative p x) == x.
Proof.
  rewrite binary_floats_are_representable.
  split; intro.
  destruct H.
  rewrite <- H.
  apply Qle_antisym.
  rewrite round_toward_negative_spec.
  apply float_le_refl.
  fold (float_le (x0) (round_toward_negative p (proj1_sig x0))).
  rewrite <- round_toward_negative_spec. apply Qle_refl.

  now exists (round_toward_negative p x).
Qed.

(* Variant of the specification. *)

Lemma round_toward_negative_spec_lt p x (f : binary_float p) :
  x < proj1_sig f <-> (round_toward_negative p x < f)%float.
Proof.
  rewrite Qlt_nge, float_lt_nge; apply negate_iff, round_toward_negative_spec.
Qed.

(* Results for round_toward_positive. *)

Lemma round_toward_positive_opp p x :
  (- round_toward_negative p x == round_toward_positive p (-x))%float.
Proof.
  unfold round_toward_negative, round_toward_positive, float_eq.
  destruct (Qeq_dec x 0), (Qeq_dec (-x) 0); simpl.
  - easy.
  - contradict n; now rewrite q.
  - contradict n; rewrite <- Qopp_opp; now rewrite q.
  - assert (binadeQ x n = binadeQ (-x) n0)%Z as H by (apply binadeQ_opp).
    rewrite H.
    match goal with
    | [ |- - (?x * ?y) == _] => setoid_replace (-(x*y)) with ((-x) * y) by ring
    end.
    apply Qmult_inj_r with (1 := twopowerQ_nonzero _).
    rewrite <- inject_Z_opp.
    apply inject_Z_injective.
    rewrite neg_floor_is_ceiling_neg.
    apply ceiling_morphism.
    field.
    apply twopowerQ_nonzero.
Qed.

Lemma round_toward_positive_spec p x (f : binary_float p) :
  x <= proj1_sig f  <->  (round_toward_positive p x <= f)%float.
Proof.
  setoid_replace x with (- - x) at 2 by ring.
  rewrite <- round_toward_positive_opp.
  setoid_replace (- round_toward_negative p (-x) <= f)%float
  with (-f <= round_toward_negative p (-x))%float.
  rewrite <- round_toward_negative_spec.

  split; intros.
  apply le_neg_switch_r.
  setoid_replace (- proj1_sig (-f)%float) with (proj1_sig f).
  easy.
  unfold float_opp, float_eq. simpl. ring.
  setoid_replace (proj1_sig f) with (- proj1_sig (-f)%float).
  apply le_neg_switch_r.
  easy.
  unfold float_opp, float_eq. simpl. ring.

  split; intros.
  now apply le_neg_switch.
  now apply le_neg_switch.
Qed.

Lemma round_toward_positive_spec_lt p x (f : binary_float p) :
  proj1_sig f < x  <->  (f < round_toward_positive p x)%float.
Proof.
  rewrite Qlt_nge, float_lt_nge; apply negate_iff, round_toward_positive_spec.
Qed.

Lemma round_toward_positive_monotonic p x y :
  x <= y  ->  (round_toward_positive p x <= round_toward_positive p y)%float.
Proof.
  intro x_le_y.
  rewrite <- round_toward_positive_spec.
  apply Qle_trans with (1 := x_le_y).
  apply round_toward_positive_spec, float_le_refl.
Qed.

(* Lemma that we'll need for the main theorem: the only discontinuities of
   round_toward_negative are elements of binary_float p.  More precisely, if
   round x < round y then there's an element of binary_float in [x, y]. *)

Theorem round_toward_negative_jumps p x y :
  (round_toward_negative p x < round_toward_negative p y)%float ->
  exists (z : binary_float p), x <= !z <= y.
Proof.
  intro round_x_le_round_y; exists (round_toward_negative p y); split.
  - now apply Qlt_le_weak, round_toward_negative_spec_lt.
  - apply round_toward_negative_spec, float_le_refl.
Qed.

(* And the corresponding result for round_toward_positive. *)

Theorem round_toward_positive_jumps p x y :
  (round_toward_positive p x < round_toward_positive p y)%float ->
  exists (z : binary_float p), x <= !z <= y.
Proof.
  intro round_x_le_round_y; exists (round_toward_positive p x); split.
  - apply round_toward_positive_spec, float_le_refl.
  - now apply Qlt_le_weak, round_toward_positive_spec_lt.
Qed.

(* Now we need to get some handle on round_ties_to_even.

   For example, we want to show that round_ties_to_even x
   is the closest float to x; i.e., that for any float f,

    | round x - x| <=  | f - x |

   Sketch of proof: consider the cases f <= x and x <= f.

   If f <= x then f <= round_down x, and so

    | round x - x | <= | x - round_down x | == x - round_down x
                    <= x - f == | f - x |.

   The case x <= f is analogous. *)

Lemma f_twopower_diff x n f :
  x - inject_Z (f(x / twopowerQ n)) * twopowerQ n ==
((x / twopowerQ n) - inject_Z (f(x / twopowerQ n))) * twopowerQ n.
Proof.
  field; apply twopowerQ_nonzero.
Qed.

Lemma round_ties_to_even_closer_than_round_toward_negative p x :
  Qabs (x - proj1_sig (round_ties_to_even p x)) <=
  Qabs (x - proj1_sig (round_toward_negative p x)).
Proof.
  unfold round_ties_to_even, round_toward_negative;
  destruct (Qeq_dec x 0) as [x_zero | x_nonzero].
  - (* Case x == 0. *)
    now rewrite x_zero.
  - (* Case x != 0. *)
    rewrite ?float_from_significand_and_exponent_Q.
    rewrite ?f_twopower_diff.
    rewrite ?Qabs_Qmult.
    rewrite ?Qabs_twopowerQ.
    generalize (x / twopowerQ (binadeQ x x_nonzero - ' p + 1)); intro q.
    twopower_right.
    apply round_as_close_as_floor.
Qed.

Lemma round_ties_to_even_closer_than_round_toward_positive p x :
  Qabs (x - proj1_sig (round_ties_to_even p x)) <=
  Qabs (x - proj1_sig (round_toward_positive p x)).
Proof.
  unfold round_ties_to_even, round_toward_positive;
  destruct (Qeq_dec x 0) as [x_zero | x_nonzero].
  - (* Case x == 0. *)
    now rewrite x_zero.
  - (* Case x != 0. *)
    rewrite ?float_from_significand_and_exponent_Q.
    rewrite ?f_twopower_diff.
    rewrite ?Qabs_Qmult.
    rewrite ?Qabs_twopowerQ.
    generalize (x / twopowerQ (binadeQ x x_nonzero - 'p + 1)); intro q.
    twopower_right.
    apply round_as_close_as_ceiling.
Qed.

Lemma round_ties_to_even_nearest p x (f : binary_float p) :
  Qabs (x - proj1_sig (round_ties_to_even p x)) <= Qabs (x - proj1_sig f).
Proof.
  destruct (Qle_ge_cases (proj1_sig f) x).
  - (* Case f <= x. *)
    apply Qle_trans with (y := Qabs (x - proj1_sig (round_toward_negative p x))).
    + (* | x - round x | <= | x - round_down x | *)
      apply round_ties_to_even_closer_than_round_toward_negative.
    + (* | x - round_down x | <= | x - f | *)
      rewrite ?Qabs_pos.
      rearrange_goal (proj1_sig f <= proj1_sig (round_toward_negative p x)).
      assert (f <= round_toward_negative p x)%float.
      now apply (round_toward_negative_spec p x f).
      assumption.
      rearrange.
      rearrange_goal (proj1_sig (round_toward_negative p x) <= x).
      apply round_toward_negative_spec.
      apply Qle_refl.
  - (* Case x <= f *)
    apply Qle_trans with (y := Qabs (x - proj1_sig (round_toward_positive p x))).
    + (* |x - round x | <= |x - round_up x | *)
      apply round_ties_to_even_closer_than_round_toward_positive.
    + (* |x - round_up x | <= |x - f| *)
      rewrite ?Qabs_neg.
      assert (round_toward_positive p x <= f)%float.
      now apply (round_toward_positive_spec p x f).
      unfold float_le in H0.
      rearrange.
      rearrange.
      rearrange_goal (x <= proj1_sig (round_toward_positive p x)).
      apply round_toward_positive_spec.
      apply Qle_refl.
Qed.

(* Claim: if round(x) < round(y) then there's a z representable in
   precision p + 1 such that x <= z <= y.

   Sketch of proof:

   First, we define next_up and next_down.

   Then we show that

   x <= (round(x) + next_up(round(x)) / 2
     <= round(y) + next_down(round(y)) / 2
     <= y.

   where the middle inequality holds because round(x) <= next_down(round(y))
   and next_up(round(x)) <= round(y).

   And those follow from:  f < g  <->  next_up(f) <= g,
                           f < g  <->  f <= next_down(g)
   for nonzero floats f and g.

   Note that next_up and next_down are only well-defined for nonzero
   floats.

   Finally we'll need to show that for a nonzero float f representable
   in precision p, (f + next_up(f)) / 2 is representable in precision
   p + 1, and similarly for next_down.
*)

Lemma round_toward_negative_le_round_ties_to_even p x :
  (round_toward_negative p x <= round_ties_to_even p x)%float.
Proof.
  unfold float_le.
  rearrange_goal (x - !round_ties_to_even p x <= x - !round_toward_negative p x).
  rewrite <- (Qabs_pos (x - !round_toward_negative p x)).
  apply Qle_trans with (y := Qabs (x - !round_ties_to_even p x)).
  apply Qle_Qabs.
  apply round_ties_to_even_nearest.
  rearrange_goal (!round_toward_negative p x <= x).
  apply round_toward_negative_spec.
  apply float_le_refl.
Qed.

Lemma round_ties_to_even_le_round_toward_positive p x :
  (round_ties_to_even p x <= round_toward_positive p x)%float.
Proof.
  unfold float_le.
  rearrange_goal (-(x - !round_ties_to_even p x) <= - (x - !round_toward_positive p x)).
  rewrite <- (Qabs_neg (x - !round_toward_positive p x)).
  apply Qle_trans with (y := Qabs (x - !round_ties_to_even p x)).
  apply Qle_Qabs_neg.
  apply round_ties_to_even_nearest.
  rearrange_goal (x <= !round_toward_positive p x).
  apply round_toward_positive_spec.
  apply float_le_refl.
Qed.

Lemma round_toward_negative_for_positive p x :
  0 < x  ->  (0 < round_toward_negative p x)%float.
Proof.
  intro.
  unfold round_toward_negative.
  destruct (Qeq_dec x 0); unfold float_lt.
  - now rewrite <- q at 2.
  - unfold float_from_significand_and_exponent; simpl;
    apply qpos.Q_mul_pos_pos with (2 := twopowerQ_positive _).
    apply Qlt_le_trans with (y := twopowerQ ('p - 1)).
    apply twopowerQ_positive.
    apply floorQ_intro.
    apply is_integer_twopowerQ.
    assert (0 < 'p)%Z by easy; omega.
    twopower_left.
    setoid_replace x with (Qabs x) at 2.
    apply (twopowerQ_binadeQ_le (binadeQ x n) x n), Z.le_refl.
    rewrite Qabs_pos. easy. apply Qlt_le_weak. easy.
Qed.

Lemma round_toward_positive_for_negative p x :
  x < 0  ->  (round_toward_positive p x < 0)%float.
Proof.
  intro; unfold round_toward_positive.
  destruct (Qeq_dec x 0); unfold float_lt.
  - now rewrite <- q at 1.
  - unfold float_from_significand_and_exponent; simpl.
    twopower_right.
    apply Qle_lt_trans with (y := -twopowerQ ('p - 1)).
    apply ceilingQ_intro.
    apply is_integer_neg.
    apply is_integer_twopowerQ.
    assert (0 < 'p)%Z by easy; omega.
    apply Qdiv_le_mult.
    apply twopowerQ_positive.
    match goal with
    | [ |- _ <= - ?a * ?b ] =>
      setoid_replace (- a * b) with (- (a * b)) by ring
    end.
    apply le_neg_switch_r.
    twopower_collect.
    twopower_exponent_simplify.
    rewrite <- Qabs_neg.
    eapply twopowerQ_binadeQ_le, Zle_refl.
    now apply Qlt_le_weak.
    rearrange_goal (0 < twopowerQ ('p - 1)).
    apply twopowerQ_positive.
Qed.

Lemma round_ties_to_even_for_positive p x :
  (0 < x)  ->  (0 < round_ties_to_even p x)%float.
Proof.
  intro; apply float_lt_le_trans with (y := round_toward_negative p x).
  - now apply round_toward_negative_for_positive.
  - apply round_toward_negative_le_round_ties_to_even.
Qed.

Lemma round_ties_to_even_for_negative p x :
  x < 0  ->  (round_ties_to_even p x < 0)%float.
Proof.
  intro; apply float_le_lt_trans with (y := round_toward_positive p x).
  - apply round_ties_to_even_le_round_toward_positive.
  - now apply round_toward_positive_for_negative.
Qed.

Lemma round_ties_to_even_for_nonzero p x :
  ~(x == 0) -> ~(round_ties_to_even p x == 0)%float.
Proof.
  intro x_nonzero.
  case (Qlt_gt_cases _ _ x_nonzero); intro.
  - now apply Qlt_not_eq, round_ties_to_even_for_negative.
  - now apply Qnot_eq_sym, Qlt_not_eq, round_ties_to_even_for_positive.
Qed.

Lemma round_toward_negative_for_nonzero p x :
  ~(x == 0) -> ~(round_toward_negative p x == 0)%float.
Proof.
  intro x_nonzero.
  case (Qlt_gt_cases _ _ x_nonzero); intro.
  - apply Qlt_not_eq.
    eapply Qle_lt_trans.
    apply round_toward_negative_spec.
    apply float_le_refl.
    easy.
  - now apply Qnot_eq_sym, Qlt_not_eq, round_toward_negative_for_positive.
Qed.

(* To show that x <= (round x + next_up (round x)) / 2 :
   This is equivalent to showing that

      2 * x <= round x + next_up (round x)

   or that

      x - round(x) <= next_up (round x) - x

   But this follows from the fact that round x is the closest
   float to x, on showing that next_up (round x) - x is nonnegative.
   That is, we must show that

       x <= next_up (round x)

   And this follows from

       x <= next_up (round_down x) <= next_up (round x)

   where the second inequality is clear, and the first inequality
   is equivalent to round_down x <= next_up (round_down x) by the
   specification of round_down.

 *)

(* x < !f iff round_down x < f *)
(* !f <= x iff !f <= round_down x. *)

Definition round_toward_negative_nz p x (x_nonzero : ~(x == 0)) : nonzero_float p.
Proof.
  refine [round_toward_negative p x].
  now apply round_toward_negative_for_nonzero.
Defined.

Definition round_toward_positive_nz p x (x_nonzero : ~(x == 0)) : nonzero_float p.
Proof.
  refine [round_toward_positive p x].
  case (Qlt_gt_cases _ _ x_nonzero); intro H.
  - now apply Qlt_not_eq, round_toward_positive_for_negative.
  - apply Qnot_eq_sym, Qlt_not_eq, Qlt_le_trans with (1 := H),
    round_toward_positive_spec, float_le_refl.
Defined.

Definition round_ties_to_even_nz p x (x_nonzero : ~(x == 0)) : nonzero_float p.
Proof.
  refine [round_ties_to_even p x]; now apply round_ties_to_even_for_nonzero.
Defined.

Lemma x_le_next_up_round_x p x x_nonzero :
  x < !!next_up (round_ties_to_even_nz p x x_nonzero).
Proof.
  apply round_toward_negative_spec_lt;
  change (round_toward_negative p x)
  with (!round_toward_negative_nz p x x_nonzero);
  apply next_up_spec_alt, round_toward_negative_le_round_ties_to_even.
Qed.

(* Now we want to show that for any nonzero x,
   x <= (round x + next_up (round x)) / 2. *)

Definition next_tie_up p x x_nonzero : Q :=
  let f := round_ties_to_even_nz p x x_nonzero in
  (!!f + !!next_up f) / 2.

Lemma in_between_not_representable p (f : nonzero_float p) x :
  !!f < x < !!next_up f  ->  ~ representable p x.
Proof.
  destruct 1 as [lower upper].
  - intro.
    set (x_as_float := (exist _ x H : binary_float p)).
    assert (~(x_as_float == 0))%float.
    + pose proof (float_by_sign_spec f); destruct (float_by_sign f).
      apply Qnot_eq_sym, Qlt_not_eq.
      apply float_lt_trans with (y := !f).
      unfold float_lt; rewrite H0; now destruct q.
      easy.
      apply Qlt_not_eq.
      apply float_lt_trans with (y := !next_up f).
      easy.
      apply next_up_negative.
      unfold float_lt; rewrite H0.
      change (!0%float) with 0.
      rearrange_goal (0 < !q).
      now destruct q.
    + set (x_as_nonzero := ((exist _ x_as_float H0) : nonzero_float p)).
      assert (!x_as_nonzero <= !f)%float by (now apply next_up_spec_alt).
      assert (!f < !x_as_nonzero)%float by easy.
      (* Now we have two contradictory inequalities. *)
      assert (!f < !f)%float by (
      now apply float_lt_le_trans with (y := !x_as_nonzero)).
      revert H3.
      apply Qlt_irrefl.
Qed.

Theorem ties_not_representable p (f : nonzero_float p) :
  ~representable p ((!!f + !!next_up f) / 2).
Proof.
  apply in_between_not_representable with (f := f).
  split; (scale_by 2; [ easy | rearrange_goal (!!f < !!next_up f);
         apply next_up_spec_alt, float_le_refl]).
Qed.

Theorem ties_representable p (f : nonzero_float p) :
  representable (p + 1) ((!!f + !!next_up f) / 2).
Proof.
  unfold next_up. unfold float_from_significand_and_exponent.
  rewrite <- reconstruct_float.
  simpl.
  rewrite <- Qmult_plus_distr_l.
  change 2 with (twopowerQ 1).
  apply scaled_representable_is_representable_div.
  apply scaled_representable_is_representable.
  rewrite <- inject_Z_plus.
  apply small_integers_are_representable.
  pose proof (low_significand_bound f).
  destruct (float_by_sign f); unfold low_significand;
  repeat (rewrite inject_Z_plus);
  setoid_replace (inject_Z (floor (low_significand_Q f)))
  with (low_significand_Q f)
    by (apply floorQ_eq, low_significand_is_integer);
  rewrite Pos2Z.inj_add.
  - rewrite Qabs_pos.
    + apply Qlt_le_succ.
      * repeat apply is_integer_add;
        (apply low_significand_is_integer || apply is_integer_inject_Z).
      * now apply is_integer_twopowerQ.
      * rearrange_goal
          ((low_significand_Q f + 1) * 2 <= twopowerQ (' p + 1)).
        (* Should make this change part of twopower_prepare. *)
        change 2 with (twopowerQ 1).
        twopower_right.
        apply Qlt_le_succ.
        apply low_significand_is_integer.
        now apply is_integer_twopowerQ.
        easy.
    + assert (0 <= low_significand_Q f) by
          (eapply Qle_trans; [ apply twopowerQ_nonnegative | apply H]).
      repeat (change 0 with (0 + 0); apply Qplus_le_compat; try easy).
  - rewrite Qabs_neg.
    + apply Qlt_le_succ.
      * apply is_integer_neg; repeat apply is_integer_add;
        (apply low_significand_is_integer || apply is_integer_inject_Z).
      * now apply is_integer_twopowerQ.
      * rearrange_goal
          (- twopowerQ (' p + 1) <= low_significand_Q f * 2).
        change 2 with (twopowerQ 1).
        apply remedial.le_neg_switch.
        twopower_right.
        apply remedial.le_neg_switch.
        easy.
    + rearrange_goal (2 * low_significand_Q f + 1 <= 0).
      apply Qlt_le_succ.
      apply is_integer_mul.
      apply is_integer_inject_Z.
      apply low_significand_is_integer.
      apply is_integer_inject_Z.
      scale_by (/ 2).
      easy.
      rearrange_goal (low_significand_Q f < 0).
      eapply Qlt_trans.
      apply H.
      rearrange_goal (0 < twopowerQ ('p - 1)).
      apply twopowerQ_positive.
Qed.

Lemma le_next_tie_up p x x_nonzero : x <= next_tie_up p x x_nonzero.
Proof.
  unfold next_tie_up.
  set (f := round_ties_to_even_nz p x x_nonzero).
  scale_by 2. now compute.
  rearrange_goal (x - !!f <= !!next_up f - x).
  apply Qle_trans with (y := Qabs (x - !!f)).
  apply Qle_Qabs.
  setoid_replace (!!next_up f - x) with (Qabs (x - !!next_up f)).
  apply round_ties_to_even_nearest.
  rewrite Qabs_neg.
  rearrange.
  rearrange_goal (x <= !!next_up f).
  unfold f.
  apply Qlt_le_weak.
  apply x_le_next_up_round_x.
Qed.

Definition next_tie_down p x x_nonzero : Q :=
  let f := round_ties_to_even_nz p x x_nonzero in
  (!!next_down f + !!f) / 2.

Lemma next_tie_down_le p x x_nonzero : next_tie_down p x x_nonzero <= x.
Proof.
  unfold next_tie_down.
  set (f := round_ties_to_even_nz p x x_nonzero).
  scale_by 2. now compute.
  rearrange_goal (-(x - !!f) <= x - !!next_down f).
  apply Qle_trans with (y := Qabs (x - !!f)).
  apply Qle_Qabs_neg.
  setoid_replace (x - !!next_down f) with (Qabs (x - !!next_down f)).
  apply round_ties_to_even_nearest.
  rewrite Qabs_pos. easy.
  rearrange_goal (!!next_down f <= x).
  apply Qlt_le_weak.
  apply round_toward_positive_spec_lt.
  change (round_toward_positive p x)
  with (!round_toward_positive_nz p x x_nonzero).
  apply next_down_spec_alt, round_ties_to_even_le_round_toward_positive.
Qed.

Theorem round_ties_to_even_jumps p x y :
  (round_ties_to_even p x < round_ties_to_even p y)%float ->
  exists h, (representable (p + 1) h /\ x <= h <= y).
Proof.
  (* Divide into cases x zero, x nonzero, and similarly for y. *)
  intro; destruct (Qeq_dec x 0) as [x_zero | x_nonzero];
  destruct (Qeq_dec y 0) as [y_zero | y_nonzero].
  - (* Case x == y == 0. Here round_ties_to_even p x < round_ties_to_even p y
       gives a contradiction. *)
    setoid_rewrite x_zero in H.
    setoid_rewrite y_zero in H.
    now compute in H.
  - (* Case x == 0, y != 0 *)
    assert (round_ties_to_even p x == 0)%float
      by (rewrite x_zero; now compute); rewrite H0 in H.
    exists (next_tie_down p y y_nonzero).
    split.
    + unfold next_tie_down; generalize (round_ties_to_even_nz p y y_nonzero);
      intro; setoid_rewrite <- next_up_next_down at 2;
      apply ties_representable.
    + split.
      * rewrite x_zero.
        unfold next_tie_down.
        apply Qmult_le_div.
        easy.
        change (0 * 2) with (0 + 0).
        apply Qplus_le_compat; apply Qlt_le_weak.
        change 0 with (! (zero_float p)).
        apply next_down_positive.
        easy.
        easy.
      * apply next_tie_down_le.
  - (* Case x != 0, y == 0 *)
    assert (round_ties_to_even p y == 0)%float
      by (rewrite y_zero; now compute); rewrite H0 in H.
    exists (next_tie_up p x x_nonzero).
    rewrite y_zero. clear H0 y_zero.
    split.
    + apply ties_representable.
    + split.
      * apply le_next_tie_up.
      * unfold next_tie_up.
        apply Qdiv_le_mult; try easy.
        change (0 * 2) with (0 + 0).
        apply Qplus_le_compat; apply Qlt_le_weak;
        now try apply next_up_negative.
  - (* Final case: x, y both nonzero. *)
    exists (next_tie_up p x x_nonzero).
    split.
    + apply ties_representable.
    + split.
      * apply le_next_tie_up.
      * apply Qle_trans with (y := next_tie_down p y y_nonzero).
        unfold next_tie_up, next_tie_down.
        apply Qmult_le_r.
        easy.
        apply Qplus_le_compat.
        apply next_down_spec.
        easy.
        apply next_up_spec.
        easy.
        apply next_tie_down_le.
Qed.

(* Characterization of representability in terms of round_toward_negative. *)

Theorem representable_iff_eq_round_toward_negative p x :
  representable p x  <->  x == !round_toward_negative p x.
Proof.
  split; intro.
  - set (x_as_float := (exist _ x H : binary_float p)).
    change x with (!x_as_float).
    apply Qle_antisym.
    + cut (x_as_float <= round_toward_negative p (!x_as_float))%float.
      easy.
      rewrite <- round_toward_negative_spec.
      apply Qle_refl.
    + apply round_toward_negative_spec, float_le_refl.
  - rewrite H.
    destruct (round_toward_negative p x).
    easy.
Qed.

(* As a corollary, representability is decidable. *)

Definition representable_dec p x : {representable p x} + {~representable p x}.
Proof.
  destruct (Qeq_dec x (!round_toward_negative p x)).
  - left.
    now apply representable_iff_eq_round_toward_negative.
  - right.
    contradict n.
    now apply representable_iff_eq_round_toward_negative.
Defined.

(* We need to know that round_ties_to_even is monotonic. *)

Lemma square_abs_is_square x :
  x * x == (Qabs x * Qabs x).
Proof.
  apply Qabs_case; intro; ring.
Qed.

Lemma square_monotonic x y :
  Qabs x <= Qabs y -> x * x <= y * y.
Proof.
  intro; setoid_rewrite square_abs_is_square;
  apply Qle_trans with (y := Qabs x * Qabs y);
    [ setoid_rewrite Qmult_comm | ];
  (apply Qmult_le_compat_r; [ easy | apply Qabs_nonneg]).
Qed.

Theorem round_ties_to_even_monotonic p x y :
  x <= y  ->  (round_ties_to_even p x <= round_ties_to_even p y)%float.
Proof.
  (* Sketch: write a and b for round x and round y.

     Since round rounds to nearest, we have:

         | x - a | <= | x - b |   (1)

     and

         | y - b | <= | y - a |   (2)

     From these it follows by squaring that

         x^2 - 2*a*x + a^2 <= x^2 - 2*b*x + b^2

     and that

         y^2 - 2*b*y + b^2 <= y^2 - 2*a*y + a^2

     Rearranging gives the two inequalities in:

        (b - a) * (2 * x) <= (b - a) * (b + a) <= (b - a) * (2 * y)

     Hence  0 <= (y - x) * (b - a), so y - x and b - a have the same
     sign, or at least one of them is zero.  But if x == y then a == b,
     so either way we have a <= b.
   *)

  intro.
  (* Divide into cases x < y, x == y. *)
  destruct (Qle_lt_eq _ _ H); clear H.
  - (* Harder case. *)
    pose proof (round_ties_to_even_nearest p x (round_ties_to_even p y)).
    pose proof (round_ties_to_even_nearest p y (round_ties_to_even p x)).
    unfold float_le.
    remember (!round_ties_to_even p x) as a.
    remember (!round_ties_to_even p y) as b.
    scale_by (2 * (y - x)).
    scale_by (/2).
    easy.
    rearrange.
    rearrange_goal ((b - a) * (2 * x) <= (b - a) * (2 * y)).
    apply Qle_trans with (y := (b - a) * (b + a)).
    + rearrange_goal ((x - a) * (x - a) <= (x - b) * (x - b)).
      now apply square_monotonic.
    + rearrange_goal ((y - b) * (y - b) <= (y - a) * (y - a)).
      now apply square_monotonic.
  - (* Easy case. *)
    rewrite H0; apply float_le_refl.
Qed.


Ltac destruct_ex_keepnames :=
  repeat match goal with
         | [ H: exists x, _ |- _ ] =>
           let x' := fresh x in destruct H as [x' H]
         end.

Goal forall (a: nat),
    (exists b, a = 2 * b) ->
    (exists b, a = 3 * b) ->
    (exists b, a = 6 * b).
Proof.
  intros a D2 D3.
  destruct_ex_keepnames.

Goal exists (p: nat * nat), fst p = snd p.
  lazymatch goal with
  | [ |- exists (x: nat), _ ] => exists 0
  | [ |- exists (x: nat * nat), _ ] => exists 0 (* <- intended failure *)
  end.
(*
Error:
Ltac call to "exists (ne_bindings_list)" failed.
The term "0" has type "nat" while it is expected to have type "(nat * nat)%type".
*)


(*******************************************************************)
Require Import Utf8.
Require Import List. Import ListNotations.
Require Import Arith.
Require Import Program Program.Wf.
Require Import Lia.
Require Import Coq.Lists.List Coq.Bool.Bool.
Scheme Equality for list.

(* Variables are v 0, v 1, v 2, and so on. *)
Inductive Var := v (i: nat).  Scheme Equality for Var.

(* Formulas in the basic language. *)
Inductive Formula0 :=  | Equal0 (x y: Var)
                       | Element0 (x y: Var)
                       | Set0 (x: Var)
                       | Bottom0
                       | Exist0 (x: Var) (φ: Formula0)
                       | If0 (φ ψ: Formula0).
(* Equal0 cannot be reduced to Element0 because of the atoms. *)
(* Set0 could be reduced to (a constant) Empty0, but it wouldn't
   be any simpler in Coq's language. *)

(* Derived notions, still considered to be in basic language. *)
Definition Not0 φ := If0 φ Bottom0.
Definition Or0 φ ψ := If0 (Not0 φ) ψ.
Definition And0 φ ψ := Not0 (Or0 (Not0 φ) (Not0 ψ)).
Definition Iff0 φ ψ := And0 (If0 φ ψ) (If0 ψ φ).
Definition All0 x φ := Not0 (Exist0 x (Not0 φ)).

(* To a variable v is assigned a type t. *)
Notation "v ↦ t" := (pair v t) (at level 60).
(* A block is a finite function from nat to nat,
   implemented as a list of pairs. It gives a typization for a
   block of interconnected variables. *)
Definition block := list (nat * nat).
(* A typization is Some list of blocks for a stratified formula,
   or None for a nonstratified one. *)
Definition Typization := option (list block).

(* Switch on equality of natural numbers. *)
Definition eq_ {T : Type} (i j : nat) (a b : T)
   := if beq_nat i j then a else b.

(* Lookup the type of (v i) in the block b. *)
Fixpoint find (i: nat) (b: block) : option nat := match b with
  | [] => None
  | (k ↦ t) :: b' => eq_ k i (Some t) (find i b')
  end.
Compute find 4 [(1,3);(4,7);(8,9)]. (* v 4 has type 7 here *)
Compute find 5 [(1,3);(4,7);(8,9)]. (* v 5 has no type here *)

(* Two blocks can be in different relationships according to their
   overlapping variables and their assigned types. *)
Inductive Alignment :=
  | Independent (* no overlap at all *)
  | Collision (* blocks are mutually inconsistent *)
  | Exact (* they agree on all the common variables *)
  | Shift1 (s: nat) (* first one can be shifted by s to be Exact *)
  | Shift2 (s: nat) (* second can be shifted by s to be Exact *).

(* How to align a block b so that v i has type t? *)
Definition align1 (i t : nat) (b : block) : Alignment :=
  match find i b with
  | None => Independent
  | Some t' => match Nat.compare t t' with
               | Eq => Exact
               | Lt => Shift1 (t' - t)
               | Gt => Shift2 (t - t')
  end          end.

(* How to align two blocks. *)
Fixpoint alignblocks (b1 b2: block) : Alignment := match b1 with
  | [] => Independent
  | (i ↦ t) :: b3 => match align1 i t b2, alignblocks b3 b2 with
      | Independent, result | result, Independent => result
      | Exact, Exact => Exact
      | Shift1 s, Shift1 s' => eq_ s s' (Shift1 s) Collision
      | Shift2 s, Shift2 s' => eq_ s s' (Shift2 s) Collision
      | Exact, Shift1 s | Shift1 s, Exact => eq_ 0 s Exact Collision
      | Exact, Shift2 s | Shift2 s, Exact => eq_ 0 s Exact Collision
      | Shift1 s, Shift2 s' | Shift2 s, Shift1 s' =>
          eq_ 0 s (eq_ 0 s' Exact Collision) Collision
      | _, _ => Collision
  end end.
Compute alignblocks [(1,2);(3,4);(4,5)] [(2,6);(3,1);(4,2)].

(* Actually merge two (already aligned) blocks into one,
   keeping the variables sorted by their indices. *)
Program Fixpoint mergealigned (b1 b2: block)
  { measure (length b1 + length b2) } : block := match b1, b2 with
    | [], _ => b2
    | _, [] => b1
    | (i ↦ t) :: b3, (i' ↦ t') :: b4 => match Nat.compare i i' with
        | Eq => (i ↦ t) :: mergealigned b3 b4
        | Lt => (i ↦ t) :: mergealigned b3 b2
        | Gt => (i' ↦ t') :: mergealigned b1 b4
    end end.
Solve All Obligations with (program_simpl; cbn; lia).
Compute mergealigned [(1,2);(3,4)] [(2,6);(3,4);(4,1)].

(* Actually shift the types in block b by s *)
Fixpoint shiftblock (b: block) (s: nat) : block := match b with
  | [] => nil
  | (k ↦ t) :: b' => (k ↦ t + s) :: shiftblock b' s
  end.

(* In order to merge a block b1 with a list of blocks tp, we
   classify the blocks in tp according to their alignment with b1. *)
Fixpoint merge1 (b1: block) (tp: list block): Typization := (*bug?*)
  match tp with
  | [] => Some [b1]
  | b2 :: bs' => match merge1 b1 bs' with
                 | None => None
                 | Some m => match alignblocks b1 b2 with
         | Collision => None
         | Independent => Some (b2 :: m)
         | Exact => Some [mergealigned b1 b2]
         | Shift1 s => Some [mergealigned (shiftblock b1 s) b2]
         | Shift2 s => Some [mergealigned b1 (shiftblock b2 s)]
  end    end     end.
Compute merge1 [(0,1); (1,1); (3,1)] [].
Compute merge1 [(0,1)] [[(0,1)]].
Compute merge1 [(0,1); (1,1); (3,1)] [[(0,1); (1,1)]].

(* Merging two lists of blocks b1 and b2,
   by merging one by one block from b1 into b2. *)
Fixpoint mergeAll (b1 b2 : list block) : Typization :=
  match b1 with | [] => Some b2
                | b :: b1' => match mergeAll b1' b2 with
                              | Some tp => merge1 b tp
                              | None => None
  end                         end.

(* Calculating the typization of any formula in basic language. *)
Fixpoint typization (φ : Formula0) : Typization :=
  match φ with
  | Equal0 (v i) (v j) => match Nat.compare i j with
                          | Eq => Some [[i ↦ 1]]
                          | Lt => Some [[i ↦ 1; j ↦ 1]]
                          | Gt => Some [[j ↦ 1; i ↦ 1]]
                          end
  | Element0 (v i) (v j) => match Nat.compare i j with
                            | Eq => None
                            | Lt => Some [[i ↦ 1; j ↦ 2]]
                            | Gt => Some [[j ↦ 2; i ↦ 1]]
                            end
  | Set0 (v i) => Some [[i ↦ 1]]
  | Bottom0 => Some []
  | Exist0 (v i) ψ => match typization ψ with
                      | Some b => merge1 [i ↦ 1] b
                      | None => None
                      end
  | If0 φ ψ => match typization φ, typization ψ with
               | Some b1, Some b2 => mergeAll b1 b2
               | _, _ => None
  end          end.

(* Now for extending our language. *)
Inductive Term :=
  | var (v : Var)
  | abs (v : Var) (φ : Formula0).

Inductive Formula1 :=
  | Equal1 (x y: Term)
  | Element1 (x y: Term)
  | Set1 (x: Term)
  | Bottom1
  | Exist1 (x: Var) (φ: Formula1)
  | If1 (φ ψ: Formula1).

(* In order to substitute,
   we must first find (an index of) a fresh variable. *)
Fixpoint max_var_basic (φ: Formula0) : nat :=
  match φ with
  | Equal0 (v i) (v j) | Element0 (v i) (v j) => max i j
  | Set0 (v i) => i
  | Bottom0 => 0 (* better: find fresh directly *)
  | Exist0 (v i) ψ => max i (max_var_basic ψ)
  | If0 φ1 φ2 => max (max_var_basic φ1) (max_var_basic φ2)
  end.

Definition max_var_term (t: Term) : nat :=
  match t with | var (v i) => i
               | abs (v i) ψ => max i (max_var_basic ψ)
  end.
Definition max_var_terms (t1 t2: Term) :=
  max (max_var_term t1) (max_var_term t2).

(* Rename variable x to v in formula φ *)
Definition rename_var (x v y: Var) := if Var_beq x y then v else y.

Fixpoint rename_basic (x: Var) (v: Var) (φ: Formula0) : Formula0 :=
  match φ with
  | Equal0 a b => Equal0 (rename_var x v a) (rename_var x v b)
  | Element0 a b => Element0 (rename_var x v a) (rename_var x v b)
  | Set0 a => Set0 (rename_var x v a)
  | Bottom0 => Bottom0
  | Exist0 a ψ => Exist0 (rename_var x v a) (rename_basic x v ψ)
  | If0 φ ψ => If0 (rename_basic x v φ) (rename_basic x v ψ)
  end.

Fixpoint max_var_extended (φ: Formula1) : nat :=
  match φ with
  | Equal1 t1 t2 | Element1 t1 t2 => max_var_terms t1 t2
  | Set1 t => max_var_term t
  | Bottom1 => 0 (* again *)
  | Exist1 (v i) ψ => max i (max_var_extended ψ)
  | If1 φ ψ => max (max_var_extended φ) (max_var_extended ψ)
  end.

Fixpoint complexity (φ: Formula0) : nat := match φ with
  | Equal0 _ _ | Element0 _ _ | Set0 _ | Bottom0 => 1
  | Exist0 x ψ => S (complexity ψ)
  | If0 φ1 φ2 => S (complexity φ1 + complexity φ2)
  end.

Lemma complexity_rename: ∀ φ x y,
  complexity (rename_basic x y φ) = complexity φ.
Proof. intros φ x y. induction φ; cbn; lia. Qed.
#[local] Hint Rewrite complexity_rename :core.

Definition freshify a φ := rename_basic a (v(S(max_var_basic φ))) φ.
Definition fresh_var_extended φ := v (S (max_var_extended φ)).

(* Substitute (free instances of) variable x
   with variable u in basic formula φ. *)
Program Fixpoint subst (x: Var) (u: Var) (φ: Formula0)
                 {measure (complexity φ)} : Formula0 :=
  match φ with
  | Equal0 _ _ | Element0 _ _ | Set0 _ => rename_basic x u φ
  | Bottom0 => Bottom0
  | If0 φ ψ => If0 (subst x u φ) (subst x u ψ)
  | Exist0 a ψ => if Var_beq a x then φ
                  else if Var_beq a u
                        then subst x u (freshify a ψ)
                        else Exist0 a (subst x u ψ)
  end.
Solve All Obligations with
  program_simpl;
  try (unfold freshify; rewrite complexity_rename);
  cbn; lia.

(* Helpful functions halfway between Element0/1 and Equal0/1. *)
Definition element (x: Var) (t: Term): Formula0 := match t with
  | var y => Element0 x y
  | abs z φ => subst z x φ
end.
Definition equal (x: Var) (t: Term): Formula0 := match t with
  | var y => Equal0 x y
  | abs z φ => And0 (All0 z (Iff0 (Element0 z x) φ)) (Set0 x)
end.

(* Eliminate abstraction terms. *)
Fixpoint tobasic (φ: Formula1): Formula0 :=
  let z := fresh_var_extended φ in match φ with
    | Equal1 (var x) (var y) => Equal0 x y
    | Equal1 a b => All0 z (Iff0 (element z a) (element z b))
    | Element1 (var x) b => element x b
    | Element1 a b => Exist0 z (And0 (element z b) (equal z a))
    | Set1 (var x) => Set0 x
    | Set1 a => Exist0 z (equal z a)
    | Bottom1 => Bottom0
    | Exist1 x φ => Exist0 x (tobasic φ)
    | If1 φ ψ => If0 (tobasic φ) (tobasic ψ)
  end.

(* Notations *)
Declare Custom Entry nff. Declare Custom Entry nft.
Declare Scope nff_scope. Declare Scope nft_scope.
Delimit Scope nff_scope with nff. Delimit Scope nft_scope with nft.
Open Scope nff_scope. Open Scope nft_scope.

Notation "\x" := (var (v 0)) (in custom nft) :nft_scope.
Notation "\y" := (var (v 1)) (in custom nft) :nft_scope.
Notation "\z" := (var (v 2)) (in custom nft) :nft_scope.
Notation "\t" := (var (v 3)) (in custom nft) :nft_scope.
Notation "\u" := (var (v 4)) (in custom nft) :nft_scope.
Notation "\v" := (var (v 5)) (in custom nft) :nft_scope.
Notation "\w" := (var (v 6)) (in custom nft) :nft_scope.
Notation "\s" := (var (v 7)) (in custom nft) :nft_scope.

Notation "$[ e ]" := e (e custom nff).
Notation "( x )" := x (in custom nff).
(* Notation "( x )" := x (in custom nft). *)
Notation "{ x }" := x (in custom nff, x constr).
Notation "\{ x }" := x (in custom nft, x constr).

Notation "x = y" := (Equal1 x y)
  (in custom nff at level 30, x custom nft, y custom nft) :nff_scope.
Notation "x ∈ y" := (Element1 x y)
  (in custom nff at level 30, x custom nft, y custom nft) :nff_scope.
Notation "set( x )" := (Set1 x)
  (in custom nff at level 20, x custom nft) :nff_scope.
Notation "⊥" := Bottom1 (in custom nff at level 0).
Notation "φ → ψ" := (If1 φ ψ) (in custom nff at level 50,
  right associativity, φ custom nff, ψ custom nff) :nff_scope.
Notation "∃ x φ" := (Exist1 x φ)
  (in custom nff at level 30, x custom nft, φ custom nff) :nff_scope.

Notation "¬ φ" := $[{φ} → ⊥]
  (in custom nff at level 40, φ custom nff) :nff_scope.
Notation "φ ∨ ψ" := $[¬ {φ} → {ψ}]
  (in custom nff at level 50) :nff_scope.
Notation "φ ∧ ψ" := $[¬({φ} → ¬ {ψ})]
  (in custom nff at level 40) :nff_scope.
Notation "φ ↔ ψ" := $[({φ} → {ψ}) ∧ ({ψ} → {φ})]
  (in custom nff at level 60) :nff_scope.
Notation "∀ x φ" := $[¬ ∃ \{x} ¬ {φ}]
  (in custom nff at level 30, x custom nft) :nff_scope.
Notation "( ∀ x ∈ S ) φ" := $[∀ \{x} (\{x} ∈ \{S} → {φ})]
  (in custom nff at level 29,
  x custom nft, S custom nft, φ custom nff) :nff_scope.
Notation "( ∃ x ∈ S ) φ" := $[∃ \{x} (\{x} ∈ \{S} ∧ {φ})]
  (in custom nff at level 29,
  x custom nft, S custom nft, φ custom nff) :nff_scope.
Notation "{ x | φ }" := (match x with
  | var y => abs y (tobasic φ)
  | _ => let z := fresh_var_extended φ in
        abs z (tobasic $[ {φ} ∧ {Equal1 (var z) x} ])
  end) (in custom nft at level 25, x custom nft, φ custom nff).

Check $[ \x ∈ \y ∧ \y ∈ \x ].
Check $[{\x | \x ∈ \z} = \z].
Definition tm := (abs (v 12) (Equal0 (v 12) (v 15))).
Compute tobasic $[ \y = \x → \x = \t ].
Compute tobasic $[ \y = \x → \x = \{tm} ].
Compute typization (tobasic $[ \y = \x → \x = \t ]).
Compute typization (tobasic $[ (\y ∈ \x → \w = \t) ↔ (\t = \x) ]).
Compute typization (tobasic $[ \x ∈ \y → \y = \x ]).
Compute typization (tobasic $[ set(\x) → \z ∈ \x ]).


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    FullAtomicJl:
        Decidable, Tag-Based Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * FullAtomicJl: Propositions about Declarative Subtyping *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.FullAtomicJl.BaseDefs.
Require Import Mechanization.FullAtomicJl.BaseProps.
Require Import Mechanization.FullAtomicJl.MatchProps.
Require Import Mechanization.FullAtomicJl.SemSubProps.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Open  Scope btjm_scope.
Open  Scope btjnf_scope.
Open  Scope btj_scope.

(* ################################################################# *)
(** ** Properties related to Matching *)
(* ################################################################# *)

(** If [v <$ t1] and [t1 << t2], then [v <$ t2]. *)
Lemma match_valty__transitive_on_sub_d : forall (t1 t2 : ty),
    |- t1 << t2 ->
    forall (v : ty),
      value_type v ->
      |- v <$ t1 ->
      |- v <$ t2.
Proof.
  intros t1 t2 Hsub.
  induction Hsub; subst; intros v Hval Hm1;
    try solve [inversion Hm1; constructor].
  - (* Refl *)
    assumption.
  - (* Trans *)
    auto.
  - (* Pair *)
    inversion Hm1; subst. inversion Hval; subst.
    constructor; [apply IHHsub1 | apply IHHsub2]; assumption.
  - (* Union *)
    inversion Hm1; subst; [apply IHHsub1 | apply IHHsub2]; tauto.
  - (* UnionR1 *)
    apply MT_Union1; assumption.
  - (* UnionR2 *)
    apply MT_Union2; assumption.
  - (* Distr1 *)
    inversion Hm1; subst. inversion H2; subst.
    apply MT_Union1; constructor; assumption.
    apply MT_Union2; constructor; assumption.
  - (* Distr2 *)
    inversion Hm1; subst; inversion H3; subst;
      [ apply MT_Union1 | apply MT_Union2]; constructor; assumption.
Qed.

(* ================================================================= *)
(** *** Correctness of Subtyping with respect to Matching *)
(* ================================================================= *)

(** [v <$ t] implies [v << t] *)
Theorem match_ty__sub_d_sound : forall (v t : ty),
    valid v ->
    |- v <$ t ->
    |- v << t.
Proof.
  intros v t HTYv H; induction H;
    try solve [
          repeat constructor
        | (apply SD_Trans with treal; repeat constructor)
        | inversion HTYv ].
  (* Pair *)   inversion HTYv; subst; constructor; tauto.
  (* Union1 *) apply union_right_1; tauto.
  (* Union2 *) apply union_right_2; tauto.
Qed.

(** [v << t] implies [v <$ t]. *)
(* DEP: match_valty__rflxv, match_valty__transitive_on_sub_d *)
Theorem match_valty__sub_d_complete : forall (v t : ty),
    |- v << t ->
    value_type v ->
    |- v <$ t.
Proof.
  intros v t H; induction H; subst; intros Hval;
    try solve [constructor | inversion Hval].
  - (* Refl *)
    apply match_valty__rflxv; assumption.
  - (* Trans *)
    specialize (IHsub_d1 Hval).
    apply match_valty__transitive_on_sub_d with t2; assumption.
  - (* Pair *)
    inversion Hval; subst. constructor; tauto.
  - (* UnionR1 *)
    apply MT_Union1. apply match_valty__rflxv; assumption.
  - (* UnionR2 *)
    apply MT_Union2. apply match_valty__rflxv; assumption.
  - (* Distr1 *)
    inversion Hval; subst. inversion H1.
  - (* Distr2 *)
    inversion Hval; subst. inversion H2.
Qed.

(* ################################################################# *)
(** ** Properties related to Normal Form *)
(* ################################################################# *)

(* ----------------------------------------------------------------- *)
(** **** Aux *)
(* ----------------------------------------------------------------- *)

(* DEP: union_sub_d__components_sub_d,
        unite_pairs_t_union, unite_pairs_union_t *)
Lemma unite_pairs__preserves_sub_d1 : forall (t1 t2 t1' t2' : ty),
    valid t1 ->
    |- t1 << t1' ->
    |- t2 << t2' ->
    |- unite_pairs t1 t2 << TPair t1' t2'.
Proof.
  intros ta; induction ta; intros tb.
  - (* CName *)
    induction tb; intros ta' tb' HTYa Hsub1 Hsub2;
      try solve [simpl; constructor; assumption].
    destruct (union_sub_d__components_sub_d _ _ _ Hsub2) as [Hsub21 Hsub22].
    rewrite unite_pairs_t_union; try resolve_not_union.
    constructor; [apply IHtb1 | apply IHtb2]; assumption.
  - (* AName *)
    induction tb; intros ta' tb' HTYa Hsub1 Hsub2;
      try solve [simpl; constructor; assumption].
    destruct (union_sub_d__components_sub_d _ _ _ Hsub2) as [Hsub21 Hsub22].
    rewrite unite_pairs_t_union; try resolve_not_union.
    constructor; [apply IHtb1 | apply IHtb2]; assumption.
  - (* Pair *)
    induction tb; intros ta' tb' HTYa Hsub1 Hsub2;
      try solve [simpl; constructor; assumption].
    destruct (union_sub_d__components_sub_d _ _ _ Hsub2) as [Hsub21 Hsub22].
    rewrite unite_pairs_t_union; try resolve_not_union.
    constructor; [apply IHtb1 | apply IHtb2]; assumption.
  - (* Union *)
    intros ta' tb' HTYa Hsub1 Hsub2.
    apply union_sub_d__components_sub_d in Hsub1.
    destruct Hsub1 as [Hsub11 Hsub12].
    rewrite unite_pairs_union_t.
    inversion HTYa; subst.
    constructor; [apply IHta1 | apply IHta2]; assumption.
  - (* Ext *)
    intros ta' tb' HTYa; inversion HTYa.
Qed.

(* DEP: union_sub_d__components_sub_d,
        unite_pairs_t_union, unite_pairs_union_t *)
Lemma unite_pairs__preserves_sub_d2 : forall (t1' t2' t1 t2 : ty),
    valid t1' ->
    |- t1 << t1' ->
    |- t2 << t2' ->
    |- TPair t1 t2 << unite_pairs t1' t2'.
Proof.
  intros ta'; induction ta'; intros tb'.
  - (* CName *)
    induction tb'; intros ta tb HTYa' Hsub1 Hsub2;
      try solve [simpl; constructor; assumption].
    rewrite unite_pairs_t_union; try resolve_not_union.
    apply SD_Trans with (TPair ta (TUnion tb'1 tb'2)).
    + constructor; constructor || assumption.
    + apply SD_Trans with (TUnion (TPair ta tb'1) (TPair ta tb'2)).
      apply SD_Distr2. apply SD_UnionL.
      apply union_right_1; apply IHtb'1; assumption || constructor.
      apply union_right_2; apply IHtb'2; assumption || constructor.
  - (* AName *)
    induction tb'; intros ta tb HTYa' Hsub1 Hsub2;
      try solve [simpl; constructor; assumption].
    rewrite unite_pairs_t_union; try resolve_not_union.
    apply SD_Trans with (TPair ta (TUnion tb'1 tb'2)).
    + constructor; constructor || assumption.
    + apply SD_Trans with (TUnion (TPair ta tb'1) (TPair ta tb'2)).
      apply SD_Distr2. apply SD_UnionL.
      apply union_right_1; apply IHtb'1; assumption || constructor.
      apply union_right_2; apply IHtb'2; assumption || constructor.
  - (* Pair *)
    induction tb'; intros ta tb HTYa' Hsub1 Hsub2;
      try solve [simpl; constructor; assumption].
    rewrite unite_pairs_t_union; try resolve_not_union.
    apply SD_Trans with (TPair ta (TUnion tb'1 tb'2)).
    + constructor; constructor || assumption.
    + apply SD_Trans with (TUnion (TPair ta tb'1) (TPair ta tb'2)).
      apply SD_Distr2. apply SD_UnionL.
      apply union_right_1; apply IHtb'1; assumption || constructor.
      apply union_right_2; apply IHtb'2; assumption || constructor.
  - (* Union *)
    intros ta tb HTYa' Hsub1 Hsub2.
    rewrite unite_pairs_union_t.
    inversion HTYa'; subst.
    apply SD_Trans with (TPair (TUnion ta'1 ta'2) tb).
    + constructor; constructor || assumption.
    + apply SD_Trans with (TUnion (TPair ta'1 tb) (TPair ta'2 tb)).
      apply SD_Distr1. apply SD_UnionL.
      apply union_right_1; apply IHta'1; assumption || constructor.
      apply union_right_2; apply IHta'2; assumption || constructor.
  - (* Ext *)
    intros ta tb HTYa'; inversion HTYa'.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Main Properties *)
(* ----------------------------------------------------------------- *)

(* DEP: unite_pairs__preserves_sub_d1 *)
Lemma mk_nf__sub_d1 : forall (t : ty),
    valid t ->
    |- MkNF(t) << t.
Proof.
  intros t HTYt; induction HTYt.
  - (* CName *)
    simpl; constructor.
  - (* AName *)
    destruct an; simpl; repeat constructor;
      apply SD_Trans with treal; constructor.
  - (* Pair *)
    simpl. pose proof (mk_nf__preserves_valid _ HTYt1) as H1.
    pose proof (mk_nf__preserves_valid _ HTYt2) as H2.
    apply unite_pairs__preserves_sub_d1; assumption.
  - (* Union *)
    simpl; constructor;
      [apply union_right_1 | apply union_right_2]; assumption.
Qed.

(* DEP: unite_pairs__preserves_sub_d3 *)
Lemma mk_nf__sub_d2 : forall (t : ty),
    valid t ->
    |- t << MkNF(t).
Proof.
  intros t HTYt; induction HTYt.
  - (* CName *)
    simpl; constructor.
  - (* AName *)
    destruct an; simpl; try constructor.
  - (* Pair *)
    simpl. pose proof (mk_nf__preserves_valid _ HTYt1) as H1.
    pose proof (mk_nf__preserves_valid _ HTYt2) as H2.
    apply unite_pairs__preserves_sub_d2; assumption.
  - (* Union *)
    simpl. constructor.
    apply union_right_1; assumption.
    apply union_right_2; assumption.
Qed.

(** Exists a declaratively equivalent type in normal form. *)
(* DEP: mk_nf__in_nf, mk_nf__sub_d1, mk_nf__sub_d2 *)
Theorem nf_exists : forall (t : ty),
    valid t ->
    exists (tn : ty),
      InNF(tn) /\
      |- tn << t /\ |- t << tn.
Proof.
  intros t HTYt. exists (MkNF(t)).
  repeat split.
  apply mk_nf__in_nf; assumption.
  apply mk_nf__sub_d1; assumption.
  apply mk_nf__sub_d2; assumption.
Qed.

(* ################################################################# *)
(** ** Relation to Semantic Subtyping *)
(* ################################################################# *)

(* ----------------------------------------------------------------- *)
(** **** Aux *)
(* ----------------------------------------------------------------- *)

(* DEP: match_ty__sub_d_sound,
        aname_sem_sub_valid_union__aname_sem_sub_component,
        matching_valpair__exists, matching_valty__exists,
        atom_pair_sem_sub_valid_union__atom_pair_sem_sub_component *)
Lemma atom_sem_sub__sub_d : forall (t : ty),
    atom_type t ->
    forall (t' : ty),
      valid t' ->
      ||- [t] <= [t'] ->
      |- t << t'.
Proof.
  intros t Hat; induction Hat; intros t' HTYt' Hval; unfold sem_sub.
  - (* CName *)
    unfold sem_sub in Hval.
    apply match_ty__sub_d_sound; try constructor.
    apply Hval; constructor.
  - (* AName *)
    unfold sem_sub in Hval.
    induction HTYt'.
    + (* CName *)
      assert (Hcontra: |- TExt n <$ TCName cn)
        by (apply Hval; constructor).
      inversion Hcontra.
    + (* AName *)
      destruct n; destruct an; subst; try apply SD_Refl.
      constructor.
      assert (Hcontra: |- TCName NCmplx <$ TAName NReal)
        by (apply Hval; constructor).
      inversion Hcontra.
    + (* Pair *)
      destruct n;
      assert (Hcontra: |- TCName NInt <$ TPair t1 t2)
        by (apply Hval; constructor);
      inversion Hcontra.
    + (* Union *)
      (* We need to prove that either all v match t1 or all v match t2 *)
      pose proof (aname_sem_sub_valid_union__aname_sem_sub_component _ _ _ HTYt'1 HTYt'2 Hval) as H.
      destruct H as [H | H];
        [ (apply union_right_1; apply IHHTYt'1)
        | (apply union_right_2; apply IHHTYt'2)];
        assumption.
  - (* Pair *)
    induction HTYt'.
    + (* CName *)
      destruct (matching_valpair__exists ta1 ta2) as [v1 [v2 [Hpv Hpm]]].
      specialize (Hval _ Hpv Hpm). inversion Hval.
    + (* AName *)
      destruct (matching_valpair__exists ta1 ta2) as [v1 [v2 [Hpv Hpm]]].
      specialize (Hval _ Hpv Hpm). inversion Hval.
    + (* Pair *)
      unfold sem_sub in Hval.
      constructor; [apply IHHat1 | apply IHHat2];
        try assumption; unfold sem_sub; intros v Hv Hm.
      * destruct (matching_valty__exists ta2) as [v' [Hv' Hm']].
        assert (Hpv: value_type (TPair v v')) by (constructor; assumption).
        assert (Hpm: |- TPair v v' <$ TPair ta1 ta2) by (constructor; assumption).
        specialize (Hval _ Hpv Hpm). inversion Hval; subst.
        assumption.
      * destruct (matching_valty__exists ta1) as [v' [Hv' Hm']].
        assert (Hpv: value_type (TPair v' v)) by (constructor; assumption).
        assert (Hpm: |- TPair v' v <$ TPair ta1 ta2) by (constructor; assumption).
        specialize (Hval _ Hpv Hpm). inversion Hval; subst.
        assumption.
    + (* Union *)
      destruct (atom_pair_sem_sub_valid_union__atom_pair_sem_sub_component _ _ Hat1 Hat2 _ _ HTYt'1 HTYt'2 Hval).
      apply union_right_1; apply IHHTYt'1; assumption.
      apply union_right_2; apply IHHTYt'2; assumption.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Main Properties *)
(* ----------------------------------------------------------------- *)

(** If [InNF(t)] and [valid t'], then [[t] <= [t']] implies [t << t']. *)
(* DEP: atom_sem_sub__sub_d *)
Theorem nf_sem_sub__sub_d : forall (t : ty),
    InNF(t) ->
    forall (t' : ty),
      valid t' ->
      ||- [t] <= [t'] ->
      |- t << t'.
Proof.
  intros t Hnf; induction Hnf; intros t' HTYt' Hval; unfold sem_sub.
  - (* Atom *)
    apply atom_sem_sub__sub_d; assumption.
  - (* Union *)
    constructor; [apply IHHnf1 | apply IHHnf2];
      try assumption;
      intros v Hv Hsub;
      try assumption; apply Hval; try assumption;
      [apply MT_Union1 | apply MT_Union2]; assumption.
Qed.

(* ################################################################# *)
(** ** Validity *)
(* ################################################################# *)

Lemma sub_d__valid1 : forall (t1 t2 : ty),
    |- t1 << t2 ->
    valid t2 ->
    valid t1.
Proof.
  intros t1 t2 Hsub; induction Hsub; intros HTY2;
    try solve [ tauto
        | constructor; tauto].
  - (* Pair *)
    inversion HTY2; subst.
    constructor; tauto.
  - (* Union1 *)
    inversion HTY2; subst; tauto.
  - (* Union2 *)
    inversion HTY2; subst; tauto.
  - (* Distr1 *)
    inversion HTY2; subst.
    inversion H1; inversion H2; subst.
    repeat constructor; tauto.
  - (* Distr2 *)
    inversion HTY2; subst.
    inversion H1; inversion H2; subst.
    repeat constructor; tauto.
Qed.


(** **
  Following Saunders Mac Lane & Ieke Moerdijk
  Sheaves in Geometry and Logic - A First Introduction to Topos theory.
  Chapter IV.1 and IV.2

  Contents :
  - definition of elementary topos ([Topos]) as a category which has:
    -) finite limits meaning:
      --) Terminal Object
      --) Binary Pullbacks
    -) Power Object
    -) Subobject Classifier
  - definition of the [KroneckerDelta] predicate and the [SingletonArrow]
  - proof that [SingletonArrow] is monic ([SingletonArrow_isMonic])
  - derivation of exponentials [Exponentials_from_Topos]
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.SubobjectClassifier.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.PowerObject.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Subobjects.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.

Local Open Scope cat.

(*
An elementary topos is a category which has:
  -) finite limits meaning:
    --) Terminal Object
    --) Binary Pullbacks
  -) Power Object
  -) Subobject Classifier
*)

Definition Topos_Structure (C : category) :=
  ∑ (PB : Pullbacks C) (T : Terminal C) (Ω : subobject_classifier T),
    (PowerObject (BinProductsFromPullbacks PB T) Ω).

Definition Topos := ∑ (C:category), Topos_Structure C.

Definition make_Topos_Structure {C:category} (PB : Pullbacks C) (T : Terminal C)
  (Ω: subobject_classifier T) (P: PowerObject (BinProductsFromPullbacks PB T) Ω)
  : Topos_Structure C.
Proof.
  split with PB.
  split with T.
  split with Ω.
  exact P.
Defined.

Definition make_Topos {C:category} (str: Topos_Structure C)
  : Topos.
Proof.
  split with C.
  exact str.
Defined.

Section ToposAccessor.

Context (C : Topos).

Definition Topos_category : category := pr1 C.
Definition Topos_Pullbacks : Pullbacks Topos_category := pr1 (pr2 C).
Definition Topos_Terminal : Terminal Topos_category := pr1 (pr2 (pr2 C)).
Definition Topos_SubobjectClassifier : subobject_classifier (Topos_Terminal) := pr1 (pr2 (pr2 (pr2 C))).
Definition Topos_BinProducts : BinProducts Topos_category := BinProductsFromPullbacks (Topos_Pullbacks) (Topos_Terminal).
Definition Topos_PowerObject : PowerObject (Topos_BinProducts) (Topos_SubobjectClassifier) := pr2 (pr2 (pr2 (pr2 C))).

End ToposAccessor.

Coercion Topos_category : Topos >->category.

Section Topos.

Context {C:Topos}.
Let T := Topos_Terminal C.
Let PB := Topos_Pullbacks C.
Let BinProd := Topos_BinProducts C.
Let P := Topos_PowerObject C.
Let Ω := Topos_SubobjectClassifier C.
Local Notation "c ⨉ d"
  := (BinProductObject C (BinProd c d))(at level 5).
  (*\bigtimes*)
Local Notation "f ⨱ g"
  := (BinProductOfArrows _ (BinProd _ _) (BinProd _ _) f g) (at level 10).
  (*\timesbar*)

Section KroneckerDelta.
(*The [KroneckerDelta] predicate is defined as
the chraracteristic morphis of the [diagonalMap],
The [SingletonArrow] is defined as
the [PowerObject_transpose] of the [KroneckerDelta]*)

Definition KroneckerDelta (B : C) : C⟦ B ⨉ B , Ω⟧.
Proof.
  use characteristic_morphism.
  + exact B.
  + use diagonalMap.
Defined.
Local Notation "'δ' B" := (KroneckerDelta B)(at level 8).

Definition SingletonArrow (B : C) : C⟦ B , (PowerObject_on_ob P) B⟧.
Proof.
  use PowerObject_transpose.
  use KroneckerDelta.
Defined.
Local Notation "'{⋅}' B" := (SingletonArrow B)(at level 8).

(*Proof that [SingletonArrow] is Monic and
  definition of his characteristic map [SingletonPred]*)

Local Definition auxpb {X B: C} (b: C⟦ X , B⟧) : Pullback (identity B ⨱ b) (diagonalMap BinProd B).
Proof.
  use make_Pullback.
  + exact X.
  + use BinProductArrow.
    - exact b.
    - exact (identity X).
  + exact b.
  + simpl.
    rewrite postcompWithBinProductArrow.
    use pathsinv0.
    use BinProductArrowUnique.
    - rewrite !assoc'.
      unfold diagonalMap'.
      now rewrite BinProductPr1Commutes.
    - rewrite !assoc'.
      unfold diagonalMap'.
      now rewrite BinProductPr2Commutes, id_left, id_right.
  + use make_isPullback.
    intros Y y1 y2 r.
    set (y11 := (y1 · (BinProductPr1 _ (BinProd B X)))).
    set (y12 := (y1 · (BinProductPr2 _ (BinProd B X)))).
    (* rewrite (BinProductArrowEta _ _ _ _ _ y1). *)
    assert (r1 := maponpaths (λ f, compose f (BinProductPr1 C (BinProd B B))) r).
    assert (r2 := maponpaths (λ f, compose f (BinProductPr2 C (BinProd B B))) r).
    simpl in r1, r2.
    unfold diagonalMap' in r1, r2.
    rewrite
      !assoc',
      BinProductOfArrowsPr1,
      BinProductPr1Commutes,
      !id_right
      in r1.
    rewrite
      !assoc',
      BinProductOfArrowsPr2,
      BinProductPr2Commutes,
      !id_right,
      assoc in r2.
    fold y11 in r1.
    fold y12 in r2.
    use make_iscontr.
    - split with y12.
      use (tpair _ _ r2).
      rewrite precompWithBinProductArrow.
      use pathsinv0.
      use BinProductArrowUnique.
      * now rewrite r2, <-r1.
      * now rewrite id_right.
    - intro t.
      induction t as (t,(tri1,tri2)).
      use subtypePath.
      * unfold isPredicate.
        intro.
        use isofhleveldirprod.
        ++ use homset_property. ++ use homset_property.
      * cbn.
        assert (Ts := maponpaths (λ f, compose f (BinProductPr2 C (BinProd B X))) tri1).
        simpl in Ts.
        rewrite assoc', BinProductPr2Commutes, id_right in Ts.
        exact Ts.
Defined.

Lemma SingletonArrow_isMonic (B: C) : isMonic ({⋅} B).
Proof.
  use make_isMonic.
  intros X b b' p.
  assert (q : (((identity B) ⨱ b) · (δ B) = ((identity B) ⨱ b') · (δ B))). {
    rewrite (PowerObject_transpose_tri P (δ B)).
    fold BinProd.
    rewrite !assoc, !BinProductOfArrows_idxcomp.
    use (maponpaths (( nat_z_iso_inv
    (PowerObject_nat_z_iso P)) (X,,B))).
    exact p.
  }
  (** Consider this diagram
    <<
                        b               !
                X   -------->   B   --------> T
                |               |             |
         b x id |    diagonalMap|             | true
                v               v             v
              B x X --------> B x B --------> Ω
                    id x b              δB
    >>
    We prove the left-hand square is a pullback
      (even when we substitue b with b') in [pbl] and [pbl'],
    the right-hand square is the definition of [KroneckerDelta]
      and it is a Pullback,
    so the whole rectangle is a pullback ([pb] [pb'])

    using [q] we note b x id and b' x id are [pullbackPr1]
    of the same diagram, thus they differ by an isomorphism [h]
  *)
  set (pbr := subobject_classifier_pullback Ω (diagonalMap BinProd B)).
  set (pbl := auxpb b).
  set (pbl' := auxpb b').
  set (pb := pullback_glue_pullback C pbr pbl).
  set (pb' := pullback_glue_pullback C pbr pbl').
  fold δ B in pb, pb'.
  transparent assert (pb'' : (Pullback ((identity B) ⨱ b' · δ B) Ω)). {
    use (Pullback_mor_paths q (idpath _)).
    exact pb.
  }
  induction (pullbackiso _ pb' pb'') as (h,(h_tri1,h_tri2)).
  cbn - [BinProd] in h, h_tri1.
  rewrite (precompWithBinProductArrow _ (BinProd B X)) in h_tri1.
  assert (h_tri11 := (maponpaths (λ f, compose f (BinProductPr1 C (BinProd B X))) h_tri1)).
  cbn beta in h_tri11.
  rewrite !BinProductPr1Commutes in h_tri11.
  assert (h_tri12 := (maponpaths (λ f, compose f (BinProductPr2 C (BinProd B X))) h_tri1)).
  cbn beta in h_tri12.
  rewrite !BinProductPr2Commutes, id_right in h_tri12.
  rewrite h_tri12, id_left in h_tri11.
  exact h_tri11.
Defined.

Definition SingletonArrow_Monic (B: C) := make_Monic C (SingletonArrow B) (SingletonArrow_isMonic B).

Definition SingletonPred (B: C) : C ⟦ PowerObject_on_ob P B , Ω ⟧.
Proof.
  use characteristic_morphism.
  { exact B. }
  use SingletonArrow_Monic.
Defined.
End KroneckerDelta.

(*In this section we show that an elementary topos has exponentials*)
Section Exponentials.

Local Notation "'δ' B" := (KroneckerDelta B)(at level 8).
Local Notation "'{⋅}' B" := (SingletonArrow B)(at level 8).

(*[v b c] in Sets would be, given an element x of b and a relation as a subset of c x b, the subset of c of all the element in relation with x*)
Let v (b c : C)
  : C ⟦ (b ⨉ (PowerObject_on_ob P (c ⨉ b))) , (PowerObject_on_ob P c) ⟧.
Proof.
  use (PowerObject_transpose).
  use (compose (BinProduct_assoc BinProd c b (PowerObject_on_ob P (c ⨉ b)))).
  use PowerObject_inPred.
Defined.

(*[u b c] in Sets would be, given a relation as a subset of c x b, the subset of b of all the element x such that (v b c) x is a Singleton*)
Let u (b c : C)
  : C ⟦ PowerObject_on_ob P (c ⨉ b) , (PowerObject_on_ob P b) ⟧.
Proof.
  use (PowerObject_transpose).
  use (compose (b:= (PowerObject_on_ob P c))).
  - use v.
  - use SingletonPred.
Defined.

Let name_true (b : C) : C ⟦ T, PowerObject_on_ob P b ⟧.
Proof.
  use (PowerObject_charname_nat_z_iso P).
  exact (TerminalArrow T b · true Ω).
Defined.

(*we are going to use [left_adjoint_from_partial], so, given (b c : C) we set up:
  Subobject_dom G0  (the object c^b : C)
  ev                (the evaluation morphism : C ⟦ b x c^b , c ⟧
  universality      (a proof which show e b c is universal)
*)

(*G0 is defined as the pullback of name_true through u*)
Let G0 (b c : C) : Subobjectscategory
  (PowerObject_on_ob P (c ⨉ b)).
Proof.
  use (PullbackSubobject PB).
  { exact (PowerObject_on_ob P b). }
  { use Subobjectscategory_ob.
    - exact T.
    - exact (name_true b).
    - use from_terminal_isMonic.
  }
  - use u.
Defined.

Local Lemma G0_Sqr (b c : C) : (Subobject_mor (G0 b c) · (u b c) = (TerminalArrow T _ ) · (name_true b)).
Proof.
  cbn.
  rewrite PullbackSqrCommutes.
  repeat use cancel_postcomposition.
  use TerminalArrowUnique.
Qed.

(** Consider this diagram
  <<
                                      ev
              ----------------------------------------------------
              |                                                  |
              |      id x G0                  v           {·}    v
            b x c^b --------> b x P(c x b) ------> Pc <--------- C
              |                 |                   |            |
       id x ! |          id x u |      SingletonPred|            |!
              v                 v                   v            v
            b x T   -------->   b x Pb -----------> Ω <--------- T
              |   id x name_true            inmap          true  ʌ
              |                                                  |
              ----------------------------------------------------
                                    !
  >>
  The left-hand square is b x (def of c^b),
  the middle square is the definition of v from u,
  the right-hand square is the definition of SingletonPred and it is a Pullback,
  the bottom distorted square is the definition of name_true.
  Every square commutes.
  We define [ev] as the [PullbackArrow] of the right-hand square
 *)

Local Definition ev_aux (b c: C) :
  (identity b) ⨱ (Subobject_mor (G0 b c)) · v b c · characteristic_morphism Ω (SingletonArrow_Monic c) =
  (identity b) ⨱ (TerminalArrow T (Subobject_dom (G0 b c))) · TerminalArrow T (BinProd b T) · Ω.
Proof.
  rewrite assoc'.
    assert (p :
      (identity b) ⨱ (u b c) · PowerObject_inPred P b =
      v b c · characteristic_morphism Ω (SingletonArrow_Monic c)).
    { use pathsinv0.
      use (PowerObject_transpose_tri P). }
    induction p.
    rewrite assoc, BinProductOfArrows_idxcomp.
    rewrite G0_Sqr.
    rewrite !assoc', <-BinProductOfArrows_idxcomp, !assoc'.
    use cancel_precomposition.
    unfold name_true.
    rewrite (PowerObject_charname_nat_z_iso_tri(b:=b) P).
    rewrite !assoc.
    use cancel_postcomposition.
    use TerminalArrowUnique.
Qed.

Let ev (b c: C) : C ⟦ b ⨉ (Subobject_dom (G0 b c)), c ⟧.
Proof.
  assert (p : PullbackObject (subobject_classifier_pullback Ω (SingletonArrow_Monic c)) = c).
  { apply idpath. }
  induction p.
  use PullbackArrow.
  - exact ((identity _) ⨱ (Subobject_mor (G0 b c)) · (v b c)).
  - exact ((identity b) ⨱ (TerminalArrow T (Subobject_dom (G0 b c)))·
      (TerminalArrow T _)).
  - apply ev_aux.
Defined.

Local Lemma ev_tri (b c : C) : ev b c · SingletonArrow_Monic c =
                                 (identity _) ⨱ ( Subobject_mor (G0 b c)) · (v b c).
Proof.
  use (PullbackArrow_PullbackPr1 (subobject_classifier_pullback Ω (SingletonArrow_Monic c))).
Qed.

(*UNIVERSALITY
  Given f : C ⟦ b x a , c ⟧ we need to show
  there is a unique g : C ⟦ a , c^b ⟧ such that f = (id x g)·ev

  we define such g as the [PullbackArrow] the following diagram
  <<
                          !
                c^b -------------> T
                 |                 |
              G0 |                 | name_true
         h       v                 v
      a --->P (c x b) ----------> Pb
                        u b c
  >>
  where h is the transpose of ((id c) x f)·(δ c)
    but as a morphism C ⟦ (c x b) x a , Ω ⟧
    (so we need to precompose [BinProduct_assoc])
*)
Let h {c b a : C} (f: C ⟦ b ⨉ a, c ⟧)
    := PowerObject_transpose P ((z_iso_inv (BinProduct_assoc BinProd c b a)) ·
                                  (identity c) ⨱ f · (δ c)).

Local Lemma h_sq {c b a : C} (f: C ⟦ b ⨉ a, c ⟧) :
  f · SingletonArrow_Monic c = (identity b) ⨱ (h f) · v b c.
Proof.
  use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso  (nat_z_iso_inv (PowerObject_nat_z_iso P)) (b ⨉ a,,c)))).
  simpl. fold BinProd.
  rewrite <-!BinProductOfArrows_idxcomp, !assoc'.
  intermediate_path ((identity c) ⨱ f · KroneckerDelta c).
  { use cancel_precomposition.
    apply pathsinv0.
    use PowerObject_transpose_tri. }
  use pathsinv0.
  intermediate_path (
    (identity c) ⨱ ((identity b) ⨱ (h f)) ·
    ((BinProduct_assoc BinProd c b (PowerObject_on_ob P c ⨉ b)) ·
    PowerObject_inPred P c ⨉ b)).
  { use cancel_precomposition.
    use pathsinv0.
    use (PowerObject_transpose_tri P). }
  rewrite assoc.
  rewrite BinProduct_OfArrows_assoc.
  use pathsinv0.
  rewrite !assoc'.
  use z_iso_inv_to_left.
  rewrite assoc.
  rewrite BinProductOfArrows_id.
  use PowerObject_transpose_tri.
Qed.

Local Lemma g_aux (c b a : C) (f: C ⟦ constprod_functor1 BinProd b a, c ⟧) : h f · u b c =
  TerminalArrow T a
  · Subobject_mor
      (Subobjectscategory_ob (name_true b)
         (from_terminal_isMonic T (PowerObject_on_ob P b) (name_true b))).
Proof.
  assert (p : name_true b = Subobject_mor
    (Subobjectscategory_ob (name_true b)
        (from_terminal_isMonic T (PowerObject_on_ob P b) (name_true b)))). { apply idpath. }
    induction p.
    use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso  (nat_z_iso_inv (PowerObject_nat_z_iso P)) (a,,b)))).
    simpl.
    fold BinProd.
    rewrite <-!BinProductOfArrows_idxcomp, !assoc'.
    intermediate_path ((identity b) ⨱ (h f) ·
    (v b c · SingletonPred c)).
    { use cancel_precomposition.
      use pathsinv0.
      use PowerObject_transpose_tri. }
    use pathsinv0.
    intermediate_path ((identity b) ⨱ (TerminalArrow T a)
    · (BinProductPr1 C (BinProd b T) · ((TerminalArrow T b · Ω)))).
    { use cancel_precomposition.
      use PowerObject_charname_nat_z_iso_tri. }
    intermediate_path (f · SingletonArrow_Monic c · SingletonPred c).
    {
      rewrite !assoc', subobject_classifier_square_commutes, !assoc.
      use cancel_postcomposition.
      use TerminalArrowEq. }
    rewrite !assoc.
    use cancel_postcomposition.
    use h_sq.
Qed.

Let g (c b a : C) (f: C ⟦ constprod_functor1 BinProd b a, c ⟧) : C ⟦ a, Subobject_dom (G0 b c) ⟧.
Proof.
  use PullbackArrow.
  + exact (h f).
  + use TerminalArrow.
  + apply g_aux.
Defined.

Local Lemma h_tri {c b a : C} (f: C ⟦ b ⨉ a, c ⟧): (g c b a f
· Subobject_mor (G0 b c) = h f).
Proof.
  use PullbackArrow_PullbackPr1.
Qed.

Local Lemma g_tri {c b a : C} (f: C ⟦ b ⨉ a, c ⟧) :
  f = (identity b) ⨱ (g c b a f) · ev b c.
Proof.
  use (MonicisMonic _ (SingletonArrow_Monic c)).
  now rewrite !assoc',
    ev_tri,
    !assoc,
    BinProductOfArrows_idxcomp,
    h_tri,
    h_sq.
Qed.

(* Opaque isBinProduct_Pullback. *)

Local Lemma universality (b c : C): is_universal_arrow_from (constprod_functor1 BinProd b) c (Subobject_dom (G0 b c)) (ev b c).
Proof.
  intros a f.
  use unique_exists.
  + exact (g c b a f).
  + use g_tri.
  + intro.
    use homset_property.
  + intros g' g_tri'.
    simpl in g_tri'.
    unfold BinProduct_of_functors_mor in g_tri'.
    simpl in g_tri'.
    use (MonicisMonic _ (Subobject_Monic (G0 b c))).
    use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso  (nat_z_iso_inv (PowerObject_nat_z_iso P)) (a,,c ⨉ b)))).
    unfold hset_z_iso_equiv.
    cbn - [BinProd G0 Subobject_mor isBinProduct_Pullback].
    fold BinProd.
    rewrite <-BinProductOfArrows_id.
    use (cancel_z_iso' (BinProduct_assoc BinProd _ _ _)).
    rewrite !assoc.
    intermediate_path (
      (identity c) ⨱ ((identity b) ⨱ (g' · Subobject_mor (G0 b c)))·
      BinProduct_assoc BinProd _ _ _ · PowerObject_inPred _ _).
    { use cancel_postcomposition.
      use pathsinv0.
      use (BinProduct_OfArrows_assoc BinProd). }
    use pathsinv0.
    intermediate_path (
      (identity c) ⨱ ((identity b) ⨱ ((g c b a f) · Subobject_mor (G0 b c)))·
      BinProduct_assoc BinProd _ _ _ · PowerObject_inPred _ _).
    { use cancel_postcomposition.
      use pathsinv0.
      use (BinProduct_OfArrows_assoc BinProd). }
    rewrite !assoc'.
    use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso  ( (PowerObject_nat_z_iso P)) (b⨉a,,c)))).
    unfold hset_z_iso_equiv.
    cbn - [BinProd G0 Subobject_mor BinProduct_assoc].
    unfold PowerObject_nt_data.
    rewrite !PowerObject_transpose_precomp.
    fold (v b c).
    rewrite <-!(BinProductOfArrows_idxcomp _ BinProd _ (Subobject_mor _)).
    rewrite !assoc'.
    rewrite <-!ev_tri.
    rewrite !assoc.
    use cancel_postcomposition.
    rewrite <-g_tri.
    use g_tri'.
Defined.

Definition Exponentials_from_Topos : Exponentials (BinProd).
Proof.
  intro b.
  use left_adjoint_from_partial.
  + intro c.
    exact (Subobject_dom (G0 b c)).
  + exact (ev b).
  + exact (universality b).
Defined.

End Exponentials.

End Topos.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Parameter ident : Type.

Parameter mk_ident: Z -> ident.

Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator .

Inductive expr  :=
  | Econst : Z -> expr
  | Evar : ident -> expr
  | Ebin : expr -> operator -> expr -> expr .

Inductive stmt  :=
  | Sskip : stmt
  | Sassign : ident -> expr -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : expr -> stmt -> stmt -> stmt
  | Swhile : expr -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.

Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).

Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).

Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a), ((get (const(
  b1):(map a b)) a1) = b1).

Definition state  := (map ident Z).

Definition eval_bin(x:Z) (op:operator) (y:Z): Z :=
  match op with
  | Oplus => (x + y)%Z
  | Ominus => (x - y)%Z
  | Omult => (x * y)%Z
  end.

Set Implicit Arguments.
Fixpoint eval_expr(s:(map ident Z)) (e:expr) {struct e}: Z :=
  match e with
  | (Econst n) => n
  | (Evar x) => (get s x)
  | (Ebin e1 op e2) => (eval_bin (eval_expr s e1) op (eval_expr s e2))
  end.
Unset Implicit Arguments.

Inductive one_step : (map ident Z) -> stmt -> (map ident Z)
  -> stmt -> Prop :=
  | one_step_assign : forall (s:(map ident Z)) (x:ident) (e:expr),
      (one_step s (Sassign x e) (set s x (eval_expr s e)) Sskip)
  | one_step_seq : forall (s:(map ident Z)) (sqt:(map ident Z)) (i1:stmt)
      (i1qt:stmt) (i2:stmt), (one_step s i1 sqt i1qt) -> (one_step s (Sseq i1
      i2) sqt (Sseq i1qt i2))
  | one_step_seq_skip : forall (s:(map ident Z)) (i:stmt), (one_step s
      (Sseq Sskip i) s i)
  | one_step_if_true : forall (s:(map ident Z)) (e:expr) (i1:stmt) (i2:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Sif e i1 i2) s i1)
  | one_step_if_false : forall (s:(map ident Z)) (e:expr) (i1:stmt)
      (i2:stmt), ((eval_expr s e) = 0%Z) -> (one_step s (Sif e i1 i2) s i2)
  | one_step_while_true : forall (s:(map ident Z)) (e:expr) (i:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Swhile e i) s (Sseq i
      (Swhile e i)))
  | one_step_while_false : forall (s:(map ident Z)) (e:expr) (i:stmt),
      ((eval_expr s e) = 0%Z) -> (one_step s (Swhile e i) s Sskip).

Axiom progress : forall (s:(map ident Z)) (i:stmt), (~ (i = Sskip)) ->
  exists sqt:(map ident Z), exists iqt:stmt, (one_step s i sqt iqt).

Inductive many_steps : (map ident Z) -> stmt -> (map ident Z)
  -> stmt -> Prop :=
  | many_steps_refl : forall (s:(map ident Z)) (i:stmt), (many_steps s i s i)
  | many_steps_trans : forall (s1:(map ident Z)) (s2:(map ident Z)) (s3:(map
      ident Z)) (i1:stmt) (i2:stmt) (i3:stmt), (one_step s1 i1 s2 i2) ->
      ((many_steps s2 i2 s3 i3) -> (many_steps s1 i1 s3 i3)).

Axiom many_steps_seq_rec : forall (s1:(map ident Z)) (s3:(map ident Z))
  (i:stmt) (i3:stmt), (many_steps s1 i s3 i3) -> ((i3 = Sskip) ->
  forall (i1:stmt) (i2:stmt), (i = (Sseq i1 i2)) -> exists s2:(map ident Z),
  (many_steps s1 i1 s2 Sskip) /\ (many_steps s2 i2 s3 Sskip)).

Axiom many_steps_seq : forall (s1:(map ident Z)) (s3:(map ident Z)) (i1:stmt)
  (i2:stmt), (many_steps s1 (Sseq i1 i2) s3 Sskip) -> exists s2:(map ident
  Z), (many_steps s1 i1 s2 Sskip) /\ (many_steps s2 i2 s3 Sskip).

Inductive fmla  :=
  | Fterm : expr -> fmla .

Definition eval_fmla(s:(map ident Z)) (f:fmla): Prop :=
  match f with
  | (Fterm e) => ~ ((eval_expr s e) = 0%Z)
  end.

Parameter subst_expr: expr -> ident -> expr -> expr.

Axiom subst_expr_def : forall (e:expr) (x:ident) (t:expr),
  match e with
  | (Econst _) => ((subst_expr e x t) = e)
  | (Evar y) => ((x = y) -> ((subst_expr e x t) = t)) /\ ((~ (x = y)) ->
      ((subst_expr e x t) = e))
  | (Ebin e1 op e2) => ((subst_expr e x t) = (Ebin (subst_expr e1 x t) op
      (subst_expr e2 x t)))
  end.

Axiom eval_subst_expr : forall (s:(map ident Z)) (e:expr) (x:ident) (t:expr),
  ((eval_expr s (subst_expr e x t)) = (eval_expr (set s x (eval_expr s t))
  e)).

Definition subst(f:fmla) (x:ident) (t:expr): fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_expr e x t))
  end.

Axiom eval_subst : forall (s:(map ident Z)) (f:fmla) (x:ident) (t:expr),
  (eval_fmla s (subst f x t)) -> (eval_fmla (set s x (eval_expr s t)) f).

Inductive triple  :=
  | T : fmla -> stmt -> fmla -> triple .

Definition valid_triple(t:triple): Prop :=
  match t with
  | (T p i q) => forall (s:(map ident Z)), (eval_fmla s p) ->
      forall (sqt:(map ident Z)), (many_steps s i sqt Sskip) ->
      (eval_fmla sqt q)
  end.

Axiom assign_rule : forall (q:fmla) (x:ident) (e:expr),
  (valid_triple (T (subst q x e) (Sassign x e) q)).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem seq_rule : forall (p:fmla) (q:fmla) (r:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple (T p i1 r)) /\ (valid_triple (T r i2 q))) ->
  (valid_triple (T p (Sseq i1 i2) q)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros p q r i1 i2 (H1,H2).
unfold valid_triple in *.
intros s Hp s' Hsteps.
generalize (many_steps_seq _ _ _ _ Hsteps).
intro H; elim H;clear H.
intros s0 (H3,H4).
apply H2 with (s:=s0); auto.
apply H1 with (s:=s); auto.
Qed.
(* DO NOT EDIT BELOW *)


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.naturals MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders
  MathClasses.orders.nat_int MathClasses.theory.integers MathClasses.theory.rings MathClasses.orders.rings.

Section contents.
Context `{Integers Z} `{Apart Z} `{!TrivialApart Z} `{!FullPseudoSemiRingOrder Zle Zlt} `{Naturals N}.

Add Ring Z : (rings.stdlib_ring_theory Z).

Lemma int_abs_unique_respectful {a b : IntAbs Z N} :
  ((=) ==> (=))%signature (int_abs Z N (ia:=a)) (int_abs Z N (ia:= b)).
Proof.
  intros x y E. unfold int_abs, int_abs_sig.
  apply (injective (naturals_to_semiring N Z)).
  destruct a as [[z1 A]|[z1 A]], b as [[z2 B]|[z2 B]].
     now rewrite A, B.
    symmetry. apply naturals.negate_to_ring. now rewrite A, B, involutive.
   apply naturals.negate_to_ring. now rewrite A, B, involutive.
  apply (injective (-)). now rewrite A, B, !involutive.
Qed.

Lemma int_abs_unique (a b : IntAbs Z N) (z : Z) :
  int_abs Z N (ia:=a) z = int_abs Z N (ia:=a) z.
Proof. now apply int_abs_unique_respectful. Qed.

Context `{!IntAbs Z N}.

Global Instance int_abs_proper: Setoid_Morphism (int_abs Z N) | 0.
Proof. split; try apply _. now apply int_abs_unique_respectful. Qed.

Context `{!SemiRing_Morphism (f : N → Z)}.

Lemma int_abs_spec x :
  { 0 ≤ x ∧ f (int_abs Z N x) = x } + { x ≤ 0 ∧ f (int_abs Z N x) = -x }.
Proof.
  unfold int_abs. destruct int_abs_sig as [[n E]|[n E]].
   left. rewrite <-E. split.
    now apply to_semiring_nonneg.
   apply (naturals.to_semiring_unique_alt _ _).
  right. split.
   apply flip_nonpos_negate. rewrite <-E. now apply to_semiring_nonneg.
  rewrite <-E. now apply (naturals.to_semiring_unique_alt _ _).
Qed.

Lemma int_abs_sig_alt x :
  { n : N | f n = x } + { n : N | f n = -x }.
Proof. destruct (int_abs_spec x) as [[??]|[??]]; eauto. Qed.

Lemma int_abs_nat n :
  int_abs Z N (f n) = n.
Proof.
  apply (injective f). destruct (int_abs_spec (f n)) as [[? E]|[? E]]; intuition.
  apply naturals.negate_to_ring. now rewrite E, involutive.
Qed.

Lemma int_abs_negate_nat n :
  int_abs Z N (-f n) = n.
Proof.
  apply (injective f). destruct (int_abs_spec (-f n)) as [[? E]|[? E]].
   symmetry. now apply naturals.negate_to_ring.
  now rewrite involutive in E.
Qed.

Lemma int_abs_negate x :
  int_abs Z N (-x) = int_abs Z N x.
Proof.
  destruct (int_abs_spec x) as [[_ E]|[_ E]].
   rewrite <-E at 1. now apply int_abs_negate_nat.
  rewrite <-E at 1. now apply int_abs_nat.
Qed.

Lemma int_abs_0_alt x : int_abs Z N x = 0 ↔ x = 0.
Proof.
  split; intros E1.
   destruct (int_abs_spec x) as [[_ E2]|[_ E2]].
    now rewrite <-E2, E1, preserves_0.
   apply flip_negate_0. now rewrite <-E2, E1, preserves_0.
  rewrite E1, <-(preserves_0 (f:=f)). now apply int_abs_nat.
Qed.

Lemma int_abs_ne_0 x : int_abs Z N x ≠ 0 ↔ x ≠ 0.
Proof. destruct (int_abs_0_alt x). intuition. Defined.

Lemma int_abs_0 : int_abs Z N 0 = 0.
Proof. now apply int_abs_0_alt. Qed.

Lemma int_abs_nonneg x :
  0 ≤ x → f (int_abs Z N x) = x.
Proof.
  intros E1. destruct (int_abs_spec x); intuition.
  setoid_replace x with (0 : Z).
   now rewrite int_abs_0, preserves_0.
  now apply (antisymmetry (≤)).
Qed.

Lemma int_abs_nonpos x :
  x ≤ 0 → f (int_abs Z N x) = -x.
Proof.
  intros E. rewrite <-int_abs_negate, int_abs_nonneg; intuition.
  now apply flip_nonpos_negate.
Qed.

Lemma int_abs_1 : int_abs Z N 1 = 1.
Proof.
  apply (injective f). rewrite preserves_1.
  apply int_abs_nonneg; solve_propholds.
Qed.

Lemma int_abs_nonneg_plus x y :
  0 ≤ x → 0 ≤ y → int_abs Z N (x + y) = int_abs Z N x + int_abs Z N y.
Proof.
  intros. apply (injective f).
  rewrite preserves_plus, !int_abs_nonneg; intuition.
  now apply nonneg_plus_compat.
Qed.

Lemma int_abs_mult x y :
  int_abs Z N (x * y) = int_abs Z N x * int_abs Z N y.
Proof.
  apply (injective f). rewrite preserves_mult.
  destruct (int_abs_spec x) as [[? Ex]|[? Ex]],
     (int_abs_spec y) as [[? Ey]|[? Ey]]; rewrite Ex, Ey.
     rewrite int_abs_nonneg. easy. now apply nonneg_mult_compat.
    rewrite int_abs_nonpos. ring. now apply nonneg_nonpos_mult.
   rewrite int_abs_nonpos. ring. now apply nonpos_nonneg_mult.
  rewrite int_abs_nonneg. ring. now apply nonpos_mult.
Qed.
End contents.