Require Import Ascii.
Require Import List.
Require Import String.
Require Import Program.
Require Import ZArith.

(** Unicode codepoint literal support, based on
    https://github.com/arthuraa/poleiro/blob/master/theories/ForceOption.v *)

Open Scope char_scope.
Open Scope Z_scope.

Fixpoint _parse_hex_digit c :=
  match c with
  | "0" => Some 0
  | "1" => Some 1
  | "2" => Some 2
  | "3" => Some 3
  | "4" => Some 4
  | "5" => Some 5
  | "6" => Some 6
  | "7" => Some 7
  | "8" => Some 8
  | "9" => Some 9
  | "A" | "a" => Some 10
  | "B" | "b" => Some 11
  | "C" | "c" => Some 12
  | "D" | "d" => Some 13
  | "E" | "e" => Some 14
  | "F" | "f" => Some 15
  | _ => None
  end.

Open Scope string_scope.

Fixpoint _parse_hex_opt_aux s accum :=
  match s with
  | "" => Some accum
  | String c s' =>
      match _parse_hex_digit c with
      | Some n => _parse_hex_opt_aux s' (16 * accum + n)
      | None => None
      end
  end.

Definition _parse_hex_opt s := _parse_hex_opt_aux s 0.

Lemma _parse_hex_opt_1: _parse_hex_opt "FFfE" = Some 65534.
Proof.
  auto.
Qed.

Lemma _parse_hex_opt_2: _parse_hex_opt "AAfg" = None.
Proof.
  auto.
Qed.

Inductive hexParseError := HexParseError.

Definition force_some {A} {ErrType} (o:option A) (e:ErrType) :
  match o with
  | Some _ => A
  | None => ErrType
  end
:=
  match o with
  | Some a => a
  | None => e
  end.

Definition parse_hex (s:string) := force_some (_parse_hex_opt s) HexParseError.

Lemma parse_hex_1: (parse_hex "FFfE" - 65534 = 0).
Proof.
  auto.
Qed.

Lemma parse_hex_2: parse_hex "AAfg" = HexParseError.
Proof.
  auto.
Qed.

Notation "U+ s" := (parse_hex s) (at level 0, no associativity).

Lemma U_1: U+"FfFe" = 65534.
Proof.
  auto.
Qed.

Lemma U_2: U+"AAfg" = HexParseError.
Proof.
  auto.
Qed.

Lemma U_3: U+"FfFe" + U+"0002" = 65536.
Proof.
  auto.
Qed.

Lemma U_4: Z.land U+"AA" U+"F0" = U+"A0".
Proof.
  auto.
Qed.

(** UTF-8 description based on https://tools.ietf.org/html/rfc3629#section-3 **)

(** UTF-8 decoding support **)

Definition _get_lo_bits c n :=
  Z.land (Z.of_N (N_of_ascii c)) ((Z.shiftl 1 n) - 1).

Fixpoint _utf8_decode_aux (s:string) (acc:Z) (phase:nat) (bound:Z): option (list Z) :=
  match s, acc, phase, bound with
  (* base case *)
  | "", 0, 0%nat, 0 => Some []
  (* normal case, decides based on the first byte *)
  | String c s, 0, 0%nat, 0 =>
    match c with
    (* ASCII character, just decodes it *)
    | Ascii _ _ _ _ _ _ _ false =>
      match _utf8_decode_aux s 0 0 0 with
      | Some l => Some ((Z.of_N (N_of_ascii c)) :: l)
      | _ => None
      end
    (* two bytes codepoint *)
    | Ascii _ _ _ _ _ false true true =>
      _utf8_decode_aux s (_get_lo_bits c 5) 1 U+"80"
    (* three bytes codepoint *)
    | Ascii _ _ _ _ false true true true =>
      _utf8_decode_aux s (_get_lo_bits c 4) 2 U+"800"
    (* four bytes codepoint *)
    | Ascii _ _ _ false true true true true =>
      _utf8_decode_aux s (_get_lo_bits c 3) 3 U+"10000"
    (* invalid *)
    | _ => None
    end
  (* final phase of multibyte codepoint *)
  | String c s, acc, 1%nat, bound =>
    (* checks c & the tail decoding *)
    match c, _utf8_decode_aux s 0 O 0 with
    | Ascii _ _ _ _ _ _ false true, Some l =>
      (* calculates the codepoint and checks it *)
      let cp := (Z.lor (Z.shiftl acc 6) (_get_lo_bits c 6)) in
      match (Z_ge_dec cp bound), (Z_le_dec cp U+"D7FF"), (Z_le_dec cp U+"DFFF") with
      | left _, left _, _ => Some (cp :: l)
      | left _, _, right _ => Some (cp :: l)
      | _, _, _ => None
      end
    | _, _ => None
    end
  (* intermediate phase of multibyte codepoint *)
  | String c s, acc, S n, bound =>
    (* checks c *)
    match c with
    | Ascii _ _ _ _ _ _ false true =>
      _utf8_decode_aux s (Z.lor (Z.shiftl acc 6) (_get_lo_bits c 6)) n bound
    | _ => None
    end
  (* invalid *)
  | _, _, _, _ => None
  end.

Definition utf8_decode (s:string): option (list Z) :=
  _utf8_decode_aux s 0 0 0.

(** UTF-8 encoding support **)

Definition _aux_enc_cp_byte cp hi lo offset :=
  ascii_of_N (Z.to_N (Z.lor offset (Z.land (Z.shiftr cp lo) ((Z.shiftl 1 (hi - lo + 1)) - 1)))).

Definition _encode_codepoint cp :=
  match (Z_lt_dec cp 0), (Z_le_dec cp U+"7F"), (Z_le_dec cp U+"7FF"),
        (Z_le_dec cp U+"D7FF"), (Z_le_dec cp U+"DFFF"),
        (Z_le_dec cp U+"FFFF"), (Z_le_dec cp U+"10FFFF") with
  | left _, _, _, _, _, _, _ => None
  | _, left _, _, _, _, _, _ =>
      Some (String (ascii_of_N (Z.to_N cp)) "")
  | _, _, left _, _, _, _, _ =>
      Some (String (_aux_enc_cp_byte cp 10 6 U+"C0")
           (String (_aux_enc_cp_byte cp 5 0 U+"80") ""))
  | _, _, _, left _, _, _, _ =>
      Some (String (_aux_enc_cp_byte cp 15 12 U+"E0")
           (String (_aux_enc_cp_byte cp 11 6 U+"80")
           (String (_aux_enc_cp_byte cp 5 0 U+"80") "")))
  | _, _, _, _, left _, _, _ => None
  | _, _, _, _, _, left _, _ =>
      Some (String (_aux_enc_cp_byte cp 15 12 U+"E0")
           (String (_aux_enc_cp_byte cp 11 6 U+"80")
           (String (_aux_enc_cp_byte cp 5 0 U+"80") "")))
  | _, _, _, _, _, _, left _ =>
      Some (String (_aux_enc_cp_byte cp 20 18 U+"F0")
           (String (_aux_enc_cp_byte cp 17 12 U+"80")
           (String (_aux_enc_cp_byte cp 11 6 U+"80")
           (String (_aux_enc_cp_byte cp 5 0 U+"80") ""))))
  | _, _, _, _, _, _, _ => None
  end.

Fixpoint utf8_encode (l:list Z) :=
  match l with
  | nil => Some ""
  | cp :: l' =>
      match _encode_codepoint cp, utf8_encode l' with
      | Some s, Some s' => Some (s ++ s')
      | _, _ => None
      end
  end.

(** Auxiliary theorems **)

Lemma land_bounds:
  forall a b,
  0 <= a ->
  0 <= b ->
  0 <= Z.land a b <= a.
Proof.
  intros a b a_bounds b_bounds.
  (* clears the easy cases first *)
  destruct a as [|p|p], b as [|q|q]; simpl; try omega;
  assert (Z.neg p < 0) as np_is_neg by apply Zlt_neg_0;
  assert (Z.neg q < 0) as nq_is_neg by apply Zlt_neg_0; try omega.
  clear a_bounds b_bounds np_is_neg nq_is_neg; generalize q; clear q.
  (* easy lemmas for positive values *)
  assert (forall p, 0 < Z.pos p) as pos_gt_0 by apply Pos2Z.is_pos.
  assert (forall p, 0 <= Z.pos p) as pos_ge_0 by (intros p'; specialize (pos_gt_0 p'); omega).
  assert (forall p, 1 <= Z.pos p) as pos_ge_1 by (intros p'; specialize (pos_gt_0 p'); omega).
  (* now the main induction, clearing the trivial cases first *)
  induction p; destruct q; try (split; discriminate);
  simpl; remember (Pos.land p q) as pnq; destruct pnq; simpl;
  specialize (IHp q); rewrite <-Heqpnq in IHp; simpl in IHp;
  unfold "<=", "?=", "?="%positive in *; simpl; auto.
  (* the final case *)
  rewrite Pos.compare_cont_spec in *; destruct (p0 ?= p)%positive; simpl; auto.
Qed.

Lemma lor_bounds:
  forall a b,
  0 <= a ->
  0 <= b ->
  a <= Z.lor a b <= a + b.
Proof.
  intros a b a_bound b_bound.
  (* clears the easy cases *)
  destruct a as [|p|p], b as [|q|q]; simpl; try omega;
  assert (Z.neg p < 0) as np_is_neg by apply Zlt_neg_0;
  assert (Z.neg q < 0) as nq_is_neg by apply Zlt_neg_0; try omega.
  clear a_bound b_bound np_is_neg nq_is_neg; generalize q; clear q.
  (* comparison lemmas *)
  assert (forall c, Pos.switch_Eq Eq c = c) as switch_eq_eq by
    (destruct c; auto).
  assert (forall p' c, Pos.compare_cont p' p' c = c) as p_p_keeps by
    (induction p'; simpl; auto).
  assert (forall p' c, Pos.compare_cont p' (Pos.succ p') c = Lt) as p_lt_succ by
    (induction p'; simpl; auto).
  (* now the main induction *)
  induction p; destruct q; simpl; try specialize IHp with (q := q);
  (* cleans up the easy cases *)
  try apply IHp; try omega;
  unfold "<=", "?=", "?="%positive in *; simpl;
  repeat rewrite p_p_keeps; repeat rewrite p_lt_succ;
  try (split; discriminate); split; try apply IHp.
  (* now the two hardest inequalities remain *)
  + repeat rewrite Pos.add_carry_spec in *; repeat rewrite Pos.compare_cont_spec in *;
    repeat rewrite Pos.compare_succ_r in *.
    remember (Pos.lor p q ?= p + q)%positive as c.
    repeat rewrite switch_eq_eq in *; destruct c; simpl; try discriminate.
    apply IHp.
  + repeat rewrite Pos.compare_cont_spec in *.
    remember (p ?= Pos.lor p q)%positive as c.
    repeat rewrite switch_eq_eq in *; destruct c; simpl; try discriminate.
    apply IHp.
Qed.

Lemma lor_acc_lo_bits_bounds:
  forall acc acc_lo acc_hi a n,
  0 <= acc_lo ->
  acc_lo <= acc_hi ->
  acc_lo <= acc <= acc_hi ->
  0 <= n < 8 ->
  Z.shiftl acc_lo n <=
  Z.lor (Z.shiftl acc n) (_get_lo_bits a n) <
  (Z.shiftl acc_hi n) + (Z.shiftl 1 n).
Proof.
  (* intros *)
  intros acc acc_lo acc_hi a n.
  intros acc_lo_bound acc_hi_bounds acc_bounds n_bounds.
  (* bounds _get_lo_bits *)
  assert (0 <= _get_lo_bits a n <= Z.shiftl 1 n - 1) as get_lo_bits_bounds.
  {
    unfold _get_lo_bits.
    rewrite Z.land_comm.
    apply land_bounds.
    + rewrite Z.shiftl_1_l.
      cut (0 < 2 ^ n). omega.
      apply Z.pow_pos_nonneg; omega.
    + apply N2Z.is_nonneg.
  }
  (* bounds the logical OR *)
  assert (Z.shiftl acc n <=
          Z.lor (Z.shiftl acc n) (_get_lo_bits a n) <=
          Z.shiftl acc n + _get_lo_bits a n) as acc_lor_lo_bounds.
  {
    apply lor_bounds.
    + rewrite Z.shiftl_mul_pow2, <-Zmult_0_r with (n := 0) by omega.
      apply Zmult_le_compat; try omega.
      apply Z.pow_nonneg; omega.
    + omega.
  }
  (* bounds the shifted accumulator *)
  assert (0 <= 2^n) as two_to_n_nonneg by (apply Z.pow_nonneg; omega).
  assert (Z.shiftl acc_lo n <= Z.shiftl acc n <= Z.shiftl acc_hi n) as shifted_acc_bounds.
  {
    repeat rewrite Z.shiftl_mul_pow2 by omega.
    split; apply Zmult_le_compat; omega.
  }
  (* finally omega has all the info it needs *)
  omega.
Qed.

(** Unicode encoding/decoding theorems **)

Inductive is_valid_unicode: list Z -> Prop :=
  | ivu_empty: is_valid_unicode nil
  | ivu_cons:
      forall c l, (0 <= c < U+"D800" \/ U+"DFFF" < c <= U+"10FFFF") ->
      is_valid_unicode l -> is_valid_unicode (c :: l).

Lemma valid_cp_is_encoded:
  forall a, (0 <= a < U+"D800" \/ U+"DFFF" < a <= U+"10FFFF") <->
  exists s, _encode_codepoint a = Some s.
Proof.
  assert (forall t:string, exists s, Some t = Some s) as ex_eq by (intros; exists t; auto).
  Ltac oor_tactic := unfold "U+" in *; simpl in *; split; [intros; omega | intros [s Habs]; discriminate].
  Ltac ir_tactic := unfold "U+" in *; simpl in *; split; [intros | intros; omega].
  intros a; unfold _encode_codepoint.
  destruct (Z_lt_dec a 0). oor_tactic.
  destruct (Z_le_dec a U+"7F"). ir_tactic; apply ex_eq.
  destruct (Z_le_dec a U+"7FF"). ir_tactic; apply ex_eq.
  destruct (Z_le_dec a U+"D7FF"). ir_tactic; apply ex_eq.
  destruct (Z_le_dec a U+"DFFF"). oor_tactic.
  destruct (Z_le_dec a U+"FFFF"). ir_tactic; apply ex_eq.
  destruct (Z_le_dec a U+"10FFFF"). ir_tactic; apply ex_eq.
  oor_tactic.
Qed.

Theorem valid_unicode_is_encoded:
  forall l, is_valid_unicode l <-> exists s, utf8_encode l = Some s.
Proof.
  induction l.
  + simpl; split; intros; [exists ""; auto | apply ivu_empty].
  + unfold utf8_encode; fold utf8_encode; split.
    - intros ivu_a_l; inversion ivu_a_l as [|a' l' a_bounds ivu_l].
      rewrite IHl in ivu_l; destruct ivu_l as [s' l_enc_eq].
      rewrite valid_cp_is_encoded in a_bounds; destruct a_bounds as [s'' a_enc_eq].
      rewrite l_enc_eq, a_enc_eq; exists (s'' ++ s'); auto.
    - remember (_encode_codepoint a) as ecp_a.
      destruct ecp_a, (utf8_encode l); try (intros [s' Habs]; discriminate).
      intros _; apply ivu_cons.
      * rewrite valid_cp_is_encoded, <-Heqecp_a; exists s; auto.
      * rewrite IHl; exists s0; auto.
Qed.

Lemma aux_decode_higher_phase_non_empty:
  forall s acc n bound,
  _utf8_decode_aux s acc (S n) bound <> Some [].
Proof.
  intros s acc n bound.
  generalize s acc; clear s acc.
  induction n.
  + destruct s.
    - intros; case acc; discriminate.
    - unfold _utf8_decode_aux; fold _utf8_decode_aux; intros.
      remember (Z.lor (Z.shiftl acc 6) (_get_lo_bits a 6)) as cp.
      destruct (_utf8_decode_aux s 0 0 0), (Z_ge_dec cp bound),
               (Z_le_dec cp U+("D7FF")), (Z_le_dec cp U+("DFFF")),
               acc, a;
      destruct b5, b6; discriminate.
  + destruct s.
    - intros; case acc; discriminate.
    - unfold _utf8_decode_aux; fold _utf8_decode_aux; intros.
      destruct acc, a; destruct b5, b6; try discriminate; apply IHn.
Qed.

Lemma encode_codepoint_non_empty:
  forall cp, _encode_codepoint cp <> Some "".
Proof.
  intros; unfold _encode_codepoint.
  destruct (Z_lt_dec cp 0). discriminate.
  destruct (Z_le_dec cp U+"7F"). discriminate.
  destruct (Z_le_dec cp U+"7FF"). discriminate.
  destruct (Z_le_dec cp U+"D7FF"). discriminate.
  destruct (Z_le_dec cp U+"DFFF"). discriminate.
  destruct (Z_le_dec cp U+"FFFF"). discriminate.
  destruct (Z_le_dec cp U+"10FFFF"). discriminate.
  discriminate.
Qed.

Lemma empty_encodes_empty:
  forall l, utf8_encode l = Some "" -> l = [].
Proof.
  destruct l as [|cp l]; unfold utf8_encode; fold utf8_encode.
  + auto.
  + remember (_encode_codepoint cp) as enc_cp.
    destruct (utf8_encode l), enc_cp as [s'|]; try discriminate.
    destruct s'.
    - assert (_encode_codepoint cp <> Some "") as enc_cp_ne by apply encode_codepoint_non_empty.
      rewrite Heqenc_cp in enc_cp_ne; exfalso; apply enc_cp_ne; auto.
    - discriminate.
Qed.

Lemma empty_decodes_empty:
  forall s, utf8_decode s = Some [] -> s = "".
Proof.
  destruct s; unfold utf8_decode.
  + auto.
  + simpl; destruct (_utf8_decode_aux s 0 0 0), a; destruct b2, b3, b4, b5, b6;
    try discriminate; intros Habs; exfalso;
    generalize Habs; apply aux_decode_higher_phase_non_empty.
Qed.

Lemma dec_lemma_1:
  forall cp s s' l,
  0 <= cp <= U+"7F" ->
  utf8_decode s' = Some l ->
  Some (String (ascii_of_N (Z.to_N cp)) "" ++ s') = Some s ->
  utf8_decode s = Some (cp :: l).
Proof.
  intros cp s s' l cp_bounds s'_dec_eq s_eq'; unfold "U+" in *; simpl in *.
  inversion s_eq' as [s_eq]; unfold utf8_decode in *; unfold _utf8_decode_aux; fold _utf8_decode_aux.
  assert (cp = Z.of_N (N_of_ascii (ascii_of_N (Z.to_N cp)))) as cp_eq.
  {
    rewrite N_ascii_embedding by (apply N2Z.inj_lt; rewrite Z2N.id; simpl; omega).
    rewrite Z2N.id; omega.
  }
  rewrite s'_dec_eq.
  destruct (ascii_of_N (Z.to_N cp)); destruct b, b0, b1, b2, b3, b4, b5, b6;
  simpl in *; try omega; rewrite cp_eq; auto.
Qed.

Lemma dec_lemma_2:
  forall cp s s' l,
  U+"7F" < cp <= U+"7FF" ->
  utf8_decode s' = Some l ->
  Some (String (_aux_enc_cp_byte cp 10 6 U+("C0"))
               (String (_aux_enc_cp_byte cp 5 0 U+("80")) "") ++ s') = Some s ->
  utf8_decode s = Some (cp :: l).
Proof.
Admitted. (** FIXME **)

Lemma dec_lemma_3:
  forall cp s s' l,
  (U+"7FF" < cp <= U+"D7FF") \/ (U+"DFFF" < cp <= U+"FFFF") ->
  utf8_decode s' = Some l ->
  Some (String (_aux_enc_cp_byte cp 15 12 U+("E0"))
               (String (_aux_enc_cp_byte cp 11 6 U+("80"))
                       (String (_aux_enc_cp_byte cp 5 0 U+("80")) "")) ++ s') = Some s ->
  utf8_decode s = Some (cp :: l).
Proof.
Admitted. (** FIXME **)

Lemma dec_lemma_4:
  forall cp s s' l,
  U+"FFFF" < cp <= U+"10FFFF" ->
  utf8_decode s' = Some l ->
  Some (String (_aux_enc_cp_byte cp 20 18 U+("F0"))
               (String (_aux_enc_cp_byte cp 17 12 U+("80"))
                       (String (_aux_enc_cp_byte cp 11 6 U+("80"))
                               (String (_aux_enc_cp_byte cp 5 0 U+("80")) ""))) ++ s') = Some s ->
  utf8_decode s = Some (cp :: l).
Proof.
Admitted. (** FIXME **)

Lemma enc_lemma_1:
  forall a s' cp l,
  Z.of_N (N_of_ascii a) < U+"80" ->
  (forall s'', utf8_encode l = Some s'' <-> _utf8_decode_aux s'' 0 0 0 = Some l) ->
  _utf8_decode_aux (String a s') 0 0 0 = Some (cp :: l) ->
  utf8_encode (cp :: l) = Some (String a s').
Proof.
  intros a s' cp l a_bounds s'_dec_eq s_dec_eq.
  unfold "U+" in *; simpl in *.
  remember (_utf8_decode_aux s' 0 0 0) as dec_s'.
  destruct a; destruct b, b0, b1, b2, b3, b4, b5, b6;
  simpl in *; try omega;
  destruct dec_s'; try discriminate;
  injection s_dec_eq; intros l_eq cp_eq; rewrite <-cp_eq; simpl;
  assert (utf8_encode l = Some s') as l_enc_eq by (apply s'_dec_eq; rewrite <-l_eq, Heqdec_s'; auto);
  rewrite l_enc_eq; auto.
Qed.

Lemma enc_fail_lemma:
  forall a s',
  (U+"80" <= Z.of_N (N_of_ascii a) < U+"C0") \/ (U+"F8" <= Z.of_N (N_of_ascii a))->
  _utf8_decode_aux (String a s') 0 0 0 = None.
Proof.
  intros a s' a_bounds; unfold "U+" in *; simpl in *.
  destruct a; destruct b, b0, b1, b2, b3, b4, b5, b6;
  simpl in *; auto; omega.
Qed.

Lemma enc_lemma_2:
  forall a s' cp l,
  U+"C0" <= Z.of_N (N_of_ascii a) < U+"E0" ->
  (forall s'', utf8_encode l = Some s'' <-> _utf8_decode_aux s'' 0 0 0 = Some l) ->
  _utf8_decode_aux (String a s') 0 0 0 = Some (cp :: l) ->
  utf8_encode (cp :: l) = Some (String a s').
Proof.
Admitted. (** FIXME **)

Lemma enc_lemma_3:
  forall a s' cp l,
  U+"E0" <= Z.of_N (N_of_ascii a) < U+"F0" ->
  (forall s'', utf8_encode l = Some s'' <-> _utf8_decode_aux s'' 0 0 0 = Some l) ->
  _utf8_decode_aux (String a s') 0 0 0 = Some (cp :: l) ->
  utf8_encode (cp :: l) = Some (String a s').
Proof.
Admitted. (** FIXME **)

Lemma enc_lemma_4:
  forall a s' cp l,
  U+"F0" <= Z.of_N (N_of_ascii a) < U+"F8" ->
  (forall s'', utf8_encode l = Some s'' <-> _utf8_decode_aux s'' 0 0 0 = Some l) ->
  _utf8_decode_aux (String a s') 0 0 0 = Some (cp :: l) ->
  utf8_encode (cp :: l) = Some (String a s').
Proof.
Admitted. (** FIXME **)

Theorem decoded_iff_encoded:
  forall l s, utf8_encode l = Some s <-> utf8_decode s = Some l.
Proof.
  induction l as [|cp l].
  + intros; simpl; split; unfold utf8_decode.
    - intros Heq; injection Heq; intros Heq'; rewrite <-Heq'; auto.
    - destruct s.
      * auto.
      * intros dec_eq; rewrite empty_decodes_empty with (s := String a s); auto.
  + intros; split.
    - unfold utf8_encode; fold utf8_encode.
      destruct (utf8_encode l) as [s'|]; try (destruct (_encode_codepoint cp); discriminate).
      unfold _encode_codepoint.
      destruct (Z_lt_dec cp 0).
        discriminate.
      destruct (Z_le_dec cp U+"7F").
        apply dec_lemma_1; try omega; apply IHl; auto.
      destruct (Z_le_dec cp U+"7FF").
        apply dec_lemma_2; try omega; apply IHl; auto.
      destruct (Z_le_dec cp U+"D7FF").
        apply dec_lemma_3; try omega; apply IHl; auto.
      destruct (Z_le_dec cp U+"DFFF").
        discriminate.
      destruct (Z_le_dec cp U+"FFFF").
        apply dec_lemma_3; try omega; apply IHl; auto.
      destruct (Z_le_dec cp U+"10FFFF").
        apply dec_lemma_4; try omega; apply IHl; auto.
        discriminate.
   - unfold utf8_decode in *.
     destruct s as [|a s'].
       simpl; discriminate.
     destruct (Z_lt_dec (Z.of_N (N_of_ascii a)) U+"80").
       apply enc_lemma_1; auto.
     destruct (Z_lt_dec (Z.of_N (N_of_ascii a)) U+"C0").
       rewrite enc_fail_lemma by omega; discriminate.
     destruct (Z_lt_dec (Z.of_N (N_of_ascii a)) U+"E0").
       apply enc_lemma_2; auto; try omega.
     destruct (Z_lt_dec (Z.of_N (N_of_ascii a)) U+"F0").
       apply enc_lemma_3; auto; try omega.
     destruct (Z_lt_dec (Z.of_N (N_of_ascii a)) U+"F8").
       apply enc_lemma_4; auto; try omega.
       rewrite enc_fail_lemma by omega; discriminate.
Qed.


Require Import CT.Algebra.Magma.
Require Import CT.Algebra.Monoid.
Require Import CT.Category.

(** * Mon: The category of monoids. *)
Program Definition Mon (T : Type) : Category :=
  {| ob := @Monoid T;
     mor := MonoidHomomorphism;
     comp := fun _ _ _ => monoid_hom_composition;
     id := fun _ => monoid_hom_id;
     assoc := fun _ _ _ _ => monoid_hom_composition_assoc
  |}.
Next Obligation.
Proof.
  symmetry.
  apply monoid_hom_composition_assoc.
Qed.
Next Obligation.
Proof.
  apply monoid_hom_eq.
  apply magma_hom_eq.
  reflexivity.
Qed.
Next Obligation.
Proof.
  apply monoid_hom_eq.
  apply magma_hom_eq.
  reflexivity.
Qed.


(* Exercise coq_list_05 *)

(* Those are the definitions from the previous exercise: *)

Inductive natlist : Set :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Fixpoint append (l m : natlist) {struct l} : natlist :=
  match l with
  | nil => m
  | cons x xs => cons x (append xs m)
  end.

(* Now define a function 'reverse' that given a list returns
   the list with the elements in the reversed order. *)
Fixpoint reverse (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons s rem => append (reverse rem) (cons s nil)
  end.

Lemma reverse_nil : reverse nil = nil.

Proof.
  unfold reverse.
  reflexivity.

Qed.

Lemma reverse_one_elt : forall a,
  reverse (cons a nil) = cons a nil.

Proof.
  intros.
  unfold reverse.
  simpl.
reflexivity.
Qed.

Lemma reverse_two_elts : forall a b,
  reverse (cons a (cons b nil)) = cons b (cons a nil).

Proof.
  intros.
  simpl.
  reflexivity.
Qed.


From LF Require Export D_Polymorphism.

Theorem silly1 : forall (n m : nat),
    n = m -> n = m.
Proof.
    intros n m eq. apply eq.
Qed.

Theorem silly2 : forall (n m o p : nat),
    n = m ->
        (n = m -> [n;o] = [m;p]) ->
            [n;o] = [m;p].
Proof.
    intros n m o p eq_1 eq_2.
    apply eq_2. apply eq_1.
Qed.

Theorem silly_ex : forall p,
    (forall n, even n = true -> even (S n) = false) ->
        (forall n, even n = false -> odd n = true) ->
            even p = true ->
                odd (S p) = true.
Proof.
    intros p eq_1 eq_2 eq_3. apply eq_2. apply eq_1. apply eq_3.
Qed.

Theorem silly3 : forall (n m : nat),
    n = m -> m = n.
Proof.
    intros n m H. symmetry. apply H.
Qed.

Search rev.

Theorem rev_exercise1 : forall (l l' : list nat),
    l = rev l' -> l' = rev l.
Proof.
    intros l l' H. rewrite -> H. symmetry. apply rev_involutive.
Qed.

(*
    apply_rewrite

    The apply tactic works similarly to
    a rewrite followed by reflexivity
    or another resolving tactic. It is
    applicable whenever the current
    problem space is identical to an
    existing proven Theorem.

    Whenever apply can be used, so can
    rewrite.
*)

Example trans_eq_example : forall (a b c d e f : nat),
    [a;b] = [c;d] ->
        [c;d] = [e;f] ->
            [a;b] = [e;f].
Proof.
    intros a b c d e f eq_1 eq_2.
    rewrite -> eq_1. rewrite -> eq_2.
    reflexivity.
Qed.

Example trans_eq : forall (X : Type) (n m o : X),
    n = m -> m = o -> n = o.
Proof.
    intros X n m o eq_1 eq_2. rewrite -> eq_1. rewrite -> eq_2.
    reflexivity.
Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
    [a;b] = [c;d] ->
        [c;d] = [e;f] ->
            [a;b] = [e;f].
Proof.
    intros a b c d e f eq_1 eq_2.
    apply trans_eq with (m := [c;d]).
    apply eq_1. apply eq_2.
Qed.

Example trans_eq_example'' : forall (a b c d e f : nat),
    [a;b] = [c;d] ->
        [c;d] = [e;f] ->
            [a;b] = [e;f].
Proof.
    intros a b c d e f eq_1 eq_2.
    transitivity [c;d].
    apply eq_1. apply eq_2.
Qed.

Example trans_eq_exercise : forall (n m o p : nat),
    m = (minustwo o) ->
        (n + p) = m ->
            (n + p) = (minustwo o).
Proof.
    intros n m o p H1 H2.
    transitivity (minustwo o).
    - (* n + p = minustwo o *)
        rewrite <- H1. apply H2.
    - (* minustwo o = minustwo o *)
        reflexivity.
Qed.

Theorem S_injective : forall (n m : nat),
    S n = S m -> n = m.
Proof.
    intros n m H1.
    assert (H2 : n = pred (S n)).
    {
        reflexivity.
    }
    rewrite -> H2. rewrite -> H1.
    simpl. reflexivity.
Qed.

Theorem S_injective' : forall (n m : nat),
    S n = S m -> n = m.
Proof.
    intros n m H.
    injection H as Hnm. apply Hnm.
Qed.

Theorem injection_ex1 : forall (n m o : nat),
    [n;m] = [o;o] -> n = m.
Proof.
    intros n m o H.
    injection H as H1 H2.
    rewrite -> H1, H2. reflexivity.
Qed.

Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = z :: j ->
        j = z :: l ->
            x = y.
Proof.
    intros X x y z l j H1 H2.
    injection H1 as H3 H4.
    symmetry in H4.
    rewrite -> H4 in H2.
    injection H2 as H5.
    rewrite -> H3, H5.
    reflexivity.
Qed.

Theorem discriminate_ex1 : forall (n m : nat),
    false = true -> n = m.
Proof.
    intros n m contra. discriminate contra.
Qed.

Theorem discriminate_ex2 : forall (n : nat),
    S n = O -> 2 + 2 = 5.
Proof.
    intros n contra. discriminate contra.
Qed.

Theorem discriminate_tf_tt :
    false = true -> true = true.
Proof.
    intros contra. discriminate contra.
Qed.

Example discriminate_ex3 : forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] -> x = z.
Proof.
    intros X x y z l j contra. discriminate contra.
Qed.

Theorem eqb_0_l : forall (n : nat),
    0 =? n = true -> n = 0.
Proof.
    intros n. destruct n as [| n' ] eqn : E.
    - (* n = 0 *)
        intros H. reflexivity.
    - (* n = S n' *)
        simpl. intros H.
        discriminate H.
Qed.

Theorem f_equal : forall (A B : Type) (f : A -> B) (x y : A),
    x = y -> f x = f y.
Proof.
    intros A B f x y eq. rewrite -> eq.
    reflexivity.
Qed.

Theorem eq_implies_succ_equal : forall (n m : nat),
    n = m -> S n = S m.
Proof.
    intros n m H. apply f_equal. apply H.
Qed.

Theorem eq_implies_succ_equal' : forall (n m : nat),
    n = m -> S n = S m.
Proof.
    intros n m H. f_equal. apply H.
Qed.

Theorem silly4 : forall (n m p q : nat),
    (n = m -> p = q) ->
        m = n ->
            q = p.
Proof.
    intros n m p q H1 H2.
    symmetry in H2. apply H1 in H2. symmetry in H2.
    apply H2.
Qed.

Theorem double_injective_FAILED : forall (n m : nat),
    double n = double m -> n = m.
Proof.
    intros n m. induction n as [| n' IHn' ].
    - (* n = 0 *)
        simpl. intros eq. destruct m as [| m'] eqn : E.
        -- reflexivity.
        -- discriminate eq.
    - (* n = S n' *)
        intros eq. destruct m as [| m'] eqn : E.
        -- discriminate eq.
        -- apply f_equal.
Abort.

Theorem double_injective : forall (n m : nat),
    double n = double m -> n = m.
Proof.
    intros n. induction n as [| n' IHn' ].
    - (* n = 0 *)
        simpl. intros m eq. destruct m as [| m'] eqn : E.
        -- reflexivity.
        -- discriminate eq.
    - (* n = S n' *)
        intros m eq. destruct m as [| m'] eqn : E.
        -- discriminate eq.
        -- f_equal. apply IHn'. simpl in eq.
           injection eq as goal. apply goal.
Qed.

Theorem eqb_true : forall (n m : nat),
    n =? m = true -> n = m.
Proof.
    intros n. induction n as [| n' IHn' ].
    - (* n = 0 *)
        intros m H. destruct m as [| m' ] eqn : E.
        -- reflexivity.
        -- discriminate H.
    - (* n = S n' *)
        intros m H. destruct m as [| m' ] eqn : E.
        -- discriminate H.
        -- f_equal. apply IHn'. simpl in H. apply H.
Qed.

(*
    eqb_true_informal

    If (eqb n m) = true, then n = m.

    We will perform induction on n,
    with an inductive hypothesis:
        If (eqb S n m) = true, then
        S n = m.

    For the base case, we have n = 0.
    So, if (eqb 0 m) = true, then 0 = m.
    We know that, as a natural number,
    m is of the form 0 or S m' for some
    m' in the natural numbers. For the
    case where m = 0, (eqb 0 0) = true
    does imply that 0 = 0, so this case
    is handled.
    For the case where m = S m', we have
    the hypothesis (eqb 0 S m') = true,
    which is clearly a contradiction.
    By the principle of explosion, this
    case is handled.

    For the inductive case, we have
    n = S n' for some n' in the natural
    numbers. So if (eqb S n' m) = true,
    then S n' = m. We know that, as a
    natural number, m is of the form 0
    or S m' for some m' in the natural
    numbers. For the case where m = 0,
    we have the hypothesis
    (eqb S n' 0) = true, which is
    clearly a contradiction. By the
    principle of explosion, this case is
    handled.
    For the case where m = S m', we have
    the hypothesis
    (eqb S n' S m') = true. By the
    property of injection, this can be
    simplified to (eqb n' m') = true.
    So, (eqb n' m') implies that
    n' = m', as injectivity can also be
    applied to S n' = S m'.
*)


Require Import Arith.

Definition Nat : Type :=
  forall A : Type, (A -> A) -> (A -> A).

Definition NatPlus(n m : Nat) : Nat
  := (fun (A : Type) (s : A -> A) (z : A) =>
         n A s (m A s z)).

Definition nat2Nat : nat -> Nat := nat_iter.

Definition Nat2nat(n : Nat) : nat := n _ S 0.

Lemma NatPlus_plus :
  forall n m, Nat2nat (NatPlus (nat2Nat n) (nat2Nat m)) = n + m.
Proof.
  intros.
  induction n.
  simpl.
  induction m.
  compute.
  ring.
  rewrite <- IHm at 2.
  compute.
  reflexivity.
  rewrite (plus_Sn_m n m).
  rewrite <- IHn.
  compute.
  reflexivity.
Qed.


From mathcomp Require Import ssreflect.
Require Import Coq.Sets.Ensembles.

Inductive IntersectionT (U : Type) (T : Type) (A : T -> Ensemble U) : Ensemble U :=
  | IntersectionT_intro : forall (x : U), (forall (t : T), In U (A t) x) -> In U (IntersectionT U T A) x.

Inductive UnionT (U : Type) (T : Type) (A : T -> Ensemble U) : Ensemble U :=
  | UnionT_intro : forall (x : U) (t : T), In U (A t) x -> In U (UnionT U T A) x.


Require Import MathClasses.interfaces.abstract_algebra.

Instance bool_eq: Equiv bool := eq.
Instance bool_bottom: Bottom bool := false.
Instance bool_top: Top bool := true.
Instance bool_join: Join bool := orb.
Instance bool_meet: Meet bool := andb.

Instance: BoundedJoinSemiLattice bool.
Proof.
  repeat (split; try apply _); repeat intro.
     apply Bool.orb_assoc.
    apply Bool.orb_false_r.
   apply Bool.orb_comm.
  apply Bool.orb_diag.
Qed.

Instance: MeetSemiLattice bool.
Proof.
  repeat (split; try apply _); repeat intro.
    apply Bool.andb_assoc.
   apply Bool.andb_comm.
  apply Bool.andb_diag.
Qed.

Instance: DistributiveLattice bool.
Proof.
  repeat (split; try apply _); repeat intro.
    apply Bool.absoption_orb.
   apply Bool.absoption_andb.
  apply Bool.orb_andb_distrib_r.
Qed.

(* We don't have a boolean algebra class yet *)


Require Import List.

Module Type DecidableEqLe.

  Parameter A : Type.
  Parameter default : A.

  Parameter le : A -> A -> Prop.
  Infix "<=" := le.
  Parameter le_total : forall a b, a <= b \/ b <= a.
  Parameter leb : A -> A -> bool.
  Infix "<=?" := leb (at level 68).
  Parameter leb_le : forall a b, a <=? b = true <-> a <= b.
  Parameter eqb : A -> A -> bool.
  Infix "=?" := eqb (at level 68).
  Parameter eqb_eq : forall a b, a =? b = true <-> a = b.

End DecidableEqLe.

Module InsertionSort (M : DecidableEqLe).

  Import M.

  Lemma neqb_neq : forall a b, a =? b = false <-> a <> b.
  Proof.
    intros ; split ; intro.
    - intro.
      apply eqb_eq in H0.
      now rewrite H0 in H.
    - destruct (a =? b) as []eqn:?.
      now apply eqb_eq in Heqb0.
      reflexivity.
  Qed.

  Lemma eqb_refl : forall a, a =? a = true.
  Proof.
    intro.
    now apply eqb_eq.
  Qed.

  Lemma eqb_sym : forall a b, a =? b = b =? a.
  Proof.
    intros.
    destruct (b =? a) as []eqn:?.
    - apply eqb_eq in Heqb0.
      subst.
      now rewrite eqb_refl.
    - apply neqb_neq in Heqb0.
      apply neqb_neq.
      intro.
      now apply eq_sym in H.
  Qed.

  Fixpoint insert l n :=
    match l with
    | nil => n::nil
    | m::t => if n <=? m then n::l else m::(insert t n)
    end.

  Fixpoint sort l :=
    match l with
    | nil => nil
    | n::t => insert (sort t) n
    end.

  Fixpoint occ l n :=
    match l with
    | nil => 0
    | m::t => if m =? n then 1 + occ t n else occ t n
    end.

  Definition is_perm l l' := forall a, occ l a = occ l' a.

  Definition is_sorted l := forall n, S n < length l -> nth n l default <= nth (S n) l default.

  Lemma insert_occ : forall l a, occ (insert l a) a = S (occ l a).
  Proof.
    induction l.
    - intro a.
      simpl.
      now rewrite eqb_refl.

    - intro b.
      simpl.
      destruct (leb b a) ; simpl.
      + destruct (a =? b) ; rewrite eqb_refl ; reflexivity.
      + destruct (a =? b) ; now rewrite IHl.
  Qed.

  Theorem insert_neq_occ : forall l a b, a <> b -> occ (insert l b) a = occ l a.
  Proof.
    intros.
    induction l ; simpl.
    - apply neqb_neq in H.
      rewrite eqb_sym.
      now rewrite H.

    - apply neqb_neq in H.
      rewrite eqb_sym in H.
      destruct (a0 =? a) as []eqn:? ; destruct (leb b a0) ; simpl ; rewrite Heqb0.
      + now rewrite H.
      + now rewrite IHl.
      + now rewrite H.
      + assumption.
  Qed.

  Lemma insert_length : forall l a, length (insert l a) = S (length l).
  Proof.
    induction l.
    - easy.

    - intro a0.
      simpl.
      destruct (a0 <=? a).
      + easy.
      + simpl.
        now rewrite IHl.
  Qed.

  Theorem sort_correct : forall l, is_perm (sort l) l.
  Proof.
    induction l.
    - simpl.
      unfold is_perm.
      intro n.
      simpl.
      reflexivity.

    - unfold is_perm.
      intro b.
      simpl.
      destruct (a =? b) as []eqn:?.
      + apply (eqb_eq) in Heqb0.
        now rewrite Heqb0, insert_occ, IHl.
      + apply (neqb_neq a b) in Heqb0.
        rewrite insert_neq_occ.
        apply IHl.
        intro.
        now apply eq_sym in H.
  Qed.

  Lemma insert_le : forall l n, exists m,
    (nth m (insert l n) default = n)
    /\ (m <= length l)%nat
    /\ (m < length l -> n <= nth (S m) (insert l n) default)
    /\ (forall p, p < length l ->
    (p < m ->
      (nth p (insert l n) default = nth p l default)
      /\ (nth p (insert l n) default <= n))
    /\ ((m <= p)%nat -> nth (S p) (insert l n) default = nth p l default)).
  Proof.
    induction l.

    - intro n.
      now exists 0.

    - intro n.
      destruct (n <=? a) as []eqn:?.
      + exists 0.
        repeat split.
        * simpl.
          now rewrite Heqb.
        * now rewrite (PeanoNat.Nat.le_0_l (length (a::l))).
        * intros.
          simpl.
          rewrite Heqb.
          simpl.
          now apply leb_le in Heqb.
        * easy.
        * easy.
        * intro.
          simpl.
          rewrite Heqb.
          reflexivity.
      + destruct (IHl n) as [m' IHl'].
        exists (S m').
        repeat split.
        * simpl.
          rewrite Heqb.
          easy.
        * destruct IHl' as [_ [H _]].
          simpl.
          now apply PeanoNat.Nat.succ_le_mono in H.
        * intro.
          simpl.
          rewrite Heqb.
          simpl.
          destruct IHl' as [_ [_ [H' _]]].
          now apply PeanoNat.Nat.succ_lt_mono, H' in H.
        * simpl.
          rewrite Heqb.
          simpl.
          destruct p.
          reflexivity.
          destruct IHl' as [_ [_ [H']]].
          pose proof (H1 p) as H1'.
          apply PeanoNat.Nat.succ_lt_mono, H1' in H.
          destruct H as [H _].
          apply PeanoNat.Nat.succ_lt_mono, H in H0.
          now destruct H0 as [H0 _].
        * simpl.
          rewrite Heqb.
          simpl.
          destruct p.
          destruct (le_total a n) as [Hle|Hle].
          easy.
          apply leb_le in Hle.
          now rewrite Hle in Heqb.
          destruct IHl' as [_ [_ [_ H']]].
          apply PeanoNat.Nat.succ_lt_mono, (H' p) in H.
          destruct H as [H _].
          apply PeanoNat.Nat.succ_lt_mono, H in H0.
          now destruct H0 as [_ H0].
        * intro.
          simpl.
          rewrite Heqb.
          simpl.
          destruct p.
          easy.
          apply PeanoNat.Nat.succ_lt_mono in H.
          apply PeanoNat.Nat.succ_le_mono in H0.
          destruct (IHl') as [_ [_ [_ H1]]].
          pose proof (H1 p) as H1.
          apply H1 in H.
          destruct H as [_ H].
          now apply H in H0.
  Qed.

  Theorem sort_correct2 : forall l, is_sorted (sort l).
  Proof.
    induction l.

    - simpl.
      unfold is_sorted.
      now intros.

    - simpl.
      unfold is_sorted.
      intros.
      destruct (insert_le (sort l) a) as [m Hinsert].
      destruct Hinsert as [Ha_in [Hm_in [Hm_next Horder]]].
      rewrite (insert_length (sort l) a) in H.
      apply PeanoNat.Nat.succ_lt_mono in H as H'.
      apply PeanoNat.Nat.succ_lt_mono in H.
      destruct (PeanoNat.Nat.lt_trichotomy n m) as [H0|[H0|H0]].
      + apply (Horder n) in H.
        destruct H as [H _].
        apply H in H0 as H1.
        destruct H1 as [H1 _].
        apply PeanoNat.Nat.le_succ_l in H0.
        apply PeanoNat.Nat.le_lteq in H0.
        destruct H0 as [H0|H0].
        * apply (PeanoNat.Nat.lt_le_trans (S n) m (length (sort l))) in H0 as H2.
          apply (Horder (S n)) in H2 as H3.
          destruct H3 as [H3 _].
          apply H3 in H0 as H4.
          clear H3.
          destruct H4 as [H4 _].
          rewrite H4, H1.
          now apply IHl.
          assumption.
        * rewrite H0, Ha_in.
          assert (n < m).
          unfold lt.
          rewrite H0.
          apply Peano.le_n.
          now apply (Horder n) in H2.
      + rewrite H0 in H, H'.
        apply Hm_next in H.
        now rewrite H0, Ha_in.
      + apply (Horder n) in H.
        destruct H as [_ H].
        apply PeanoNat.Nat.lt_le_incl in H0 as H1.
        apply H in H1.
        apply PeanoNat.Nat.lt_le_pred in H0 as H2.
        pose proof (PeanoNat.Nat.le_pred_l n) as H3.
        apply (PeanoNat.Nat.le_lt_trans (PeanoNat.Nat.pred n) n (length (sort l))) in H3.
        apply (Horder (PeanoNat.Nat.pred n)) in H3.
        destruct H3 as [_ H3].
        apply H3 in H2.
        clear H3.
        apply (PeanoNat.Nat.le_lt_trans 0 m n) in H0.
        apply PeanoNat.Nat.lt_neq, PeanoNat.Nat.neq_sym in H0.
        apply (PeanoNat.Nat.succ_pred n) in H0 as H3.
        rewrite H3 in H2.
        rewrite H1, H2.
        rewrite <- H3 at 2.
        apply IHl.
        now rewrite H3.
        now pose proof (PeanoNat.Nat.le_0_l m) as H3.
        assumption.
  Qed.

End InsertionSort.

Module NatDecidableEqLe <: DecidableEqLe.

  Definition A := nat.
  Definition le := Peano.le.
  Definition le_total := PeanoNat.Nat.le_ge_cases.
  Definition leb := PeanoNat.Nat.leb.
  Definition leb_le := PeanoNat.Nat.leb_le.
  Definition eqb := PeanoNat.Nat.eqb.
  Definition eqb_eq := PeanoNat.Nat.eqb_eq.
  Definition default := 0.

End NatDecidableEqLe.

Module NatInsertionSort := InsertionSort NatDecidableEqLe.


Require Import Coq.Arith.Compare_dec.
Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.

Opaque lt_eq_lt_dec.

(** Terms *)
Inductive Trm : Type :=
| Trm_Unit : Trm
| Trm_Var : nat -> Trm
| Trm_Func : Trm -> Trm
| Trm_App : Trm -> Trm -> Trm
.

Notation un := (Trm_Unit).
Notation "𝔳( n )" := (Trm_Var n).
Notation "'λ' f" := (Trm_Func f) (at level 0).
Notation "x · y" := (Trm_App x y) (at level 50, y at next level, left associativity).

(** Types *)
Inductive Typ  : Type :=
| Typ_Unit : Typ
| Typ_Func : Typ -> Typ -> Typ
.

Notation Un := (Typ_Unit).
Notation "A —≻ B" := (Typ_Func A B) (at level 99, right associativity).

(** A context is just a list of types.
The head of the list is the type of the variable 0. *)
Inductive Context :=
| Emp : Context
| Cons : Typ -> Context -> Context
.

Notation ε := Emp.
Notation "A ,, C" := (Cons A C) (at level 100).

Reserved Notation "Δ +++ Γ" (at level 60, right associativity).

Fixpoint ContextCompose (Δ Γ : Context) : Context :=
  match Δ with
  | ε => Γ
  | (A,, Δ') => A,, Δ' +++ Γ
  end
where "Δ +++ Γ" := (ContextCompose Δ Γ)
.

Fixpoint CLen (Γ : Context) : nat :=
  match Γ with
  | ε => O
  | (A,, Γ') => S (CLen Γ')
  end
.

Reserved Notation "[ Γ ] ⊢ t ::: T" (at level 100, no associativity).

(** Typing relation *)
Inductive Typed : Context -> Trm -> Typ -> Prop :=
| Tpd_Un : forall (Γ: Context), [Γ] ⊢ un ::: Un
| Tpd_Var : forall (T : Typ) (Γ Γ' : Context),
    [Γ +++ (T,, Γ')] ⊢ 𝔳(CLen Γ) ::: T
| Tpd_Func : forall (Γ : Context) (t : Trm) (T T' : Typ),
    ([T,, Γ] ⊢ t ::: T') -> ([Γ] ⊢ (λ t) ::: (T —≻ T'))
| Tpd_App : forall (Γ : Context) (t t' : Trm) (T T' : Typ),
    ([Γ] ⊢ t ::: (T —≻ T')) -> ([Γ] ⊢ t' ::: T) -> ([Γ] ⊢ (t · t') ::: T')
where "[ Γ ] ⊢ t ::: T " := (Typed Γ t T).

Theorem not_lt_O : forall n, ~ (n < 0).
Proof.
  intros n H.
  inversion H.
Qed.

(** shift free m-variables (greater than or equal to  m) by n. *)
Fixpoint shift (n : nat) (m : nat) (t : Trm) : Trm :=
  match t with
  | un => un
  | 𝔳(y) => if le_dec m y then 𝔳(n + y) else 𝔳(y)
  | λ f => λ (shift n (S m) f)
  | t1 · t2 => (shift n m t1) · (shift n (m) t2)
  end
.

Reserved Notation "t [ m // x ]" (at level 100, no associativity).

(** substitution *)
Fixpoint subst (t : Trm) (x : nat) (m : Trm) : Trm :=
  match t with
  | un => un
  | 𝔳(y) =>
    match lt_eq_lt_dec x y with
    | inleft H =>
      match H with
      | left H' =>
        (match y as u return x < u -> Trm with
         | O => fun G => False_rect _ (not_lt_O _ G)
         | S y' => fun G => 𝔳(y')
         end)
          H'
      | right _ => m
      end
    | inright _ =>
      𝔳(y)
    end
  | λ f => λ (f [(shift 1 O m) // (S x)])
  | t1 · t2 => (t1 [m // x]) · (t2 [m // x])
  end
where "t [ m // x ]" := (subst t x m)
.

Theorem shift_O (t : Trm) (m : nat) : shift O m t = t.
Proof.
  revert m.
  induction t; cbn; intros m; trivial; try destruct le_dec; trivial.
  + rewrite <- IHt at 2; trivial.
  + rewrite <- IHt1 at 2; rewrite <- IHt2 at 2; trivial.
Qed.

(** Shifts can be swapped changing their arguments. *)
Theorem shift_shift (t : Trm) (k l m n : nat) :
  shift k l (shift m (l + n) t) = shift m (k + l + n) (shift k l t).
Proof.
  revert k l m n.
  induction t; intros k l m n'; cbn;
  trivial; repeat (try destruct le_dec; cbn);
  trivial; try omega.
  - match goal with
      |- 𝔳(?A) = 𝔳(?B) => replace A with B by omega; trivial
    end.
  - change (S (l + n')) with ((S l) + n').
    rewrite IHt.
    match goal with
      |- _ (shift _ ?A _) = _ (shift _ ?B _) => replace A with B by omega; trivial
    end.
  - rewrite IHt1.
    rewrite IHt2.
    trivial.
Qed.

Lemma Typed_shift (Δ Δ' Γ : Context) (t : Trm) (T : Typ) :
  ([Δ' +++ Γ]⊢ t ::: T) ->
  [Δ' +++ Δ +++ Γ]⊢ shift (CLen Δ) (CLen Δ') t ::: T
.
Proof.
  intros H.
  remember (Δ' +++ Γ) as ξ.
  revert Δ' Δ Heqξ.
  set (H' := H); clearbody H'.
  induction H; cbn in *.
  + constructor.
  + intros Δ' Δ Heqξ.
    destruct le_dec.
    admit.
    admit.
  + intros Δ' Δ Heqξ.
    constructor.
    change (T,, Δ' +++ Δ +++ Γ) with ((T,, Δ') +++ Δ +++ Γ).
    apply IHTyped; trivial.
    rewrite Heqξ.
    trivial.
  + intros Δ.
    econstructor; eauto.
Admitted.

Theorem Typed_Subst (Δ Δ' Γ : Context) (t t' : Trm) (T T' : Typ) :
  ([Δ' +++ Γ] ⊢ t' ::: T') ->
  ([Δ' +++ Δ +++ (T',, Γ)] ⊢ t ::: T) ->
  ([Δ' +++ Δ +++ Γ] ⊢ t [(shift (CLen Δ) (CLen Δ') t') // (CLen (Δ' +++ Δ))] ::: T)
.
Proof.
  intros H1 H2.
  remember (Δ' +++ Δ +++ (T',, Γ)) as Υ.
  revert Δ Δ' t' HeqΥ H1.
  set (H2' := H2); clearbody H2'.
  induction H2; intros Δ Δ' s HeqΥ H1; cbn in *.
  - constructor.
  - destruct lt_eq_lt_dec as [[G|G]|G].
    + destruct Γ0; [inversion G|]; cbn in *.
      rewrite HeqΥ in H2'.
        admit.
    + apply Typed_shift.
      rewrite HeqΥ in H2'.
      admit.
    + rewrite HeqΥ in H2'.
      admit.
  - constructor.
    set (W := fun t => shift_shift t 1 0); cbn in W; rewrite W; clear W.
    change (T,, Δ' +++ Δ +++ Γ) with ((T,, Δ') +++ Δ +++ Γ).
    change (S (CLen (Δ' +++ Δ))) with (CLen (T,, Δ' +++ Δ)).
    apply IHTyped; trivial.
    + rewrite HeqΥ.
      trivial.
    + admit.
  - econstructor.
    + apply IHTyped1; trivial.
    + apply IHTyped2; trivial.
Admitted.

Reserved Notation "s ↝₁ t" (at level 100, no associativity).

Inductive Red1 : Trm -> Trm -> Type :=
| Red_Refl : forall t, t ↝₁ t
| Beta : forall t1 s1 t2 s2, (t1 ↝₁ s1) -> (t2 ↝₁ s2) -> ((λ t1) · t2) ↝₁ (s1 [s2 // O])
| Red_App : forall t1 t2 t13 t23, (t1 ↝₁ t13) -> (t2 ↝₁ t23) -> (t1 · t2) ↝₁ (t13 · t23)
| Red_Func : forall t1 t2, (t1 ↝₁ t2) -> (λ t1) ↝₁ (λ t2)
where "s ↝₁ t" := (Red1 s t).

Hint Constructors Red1.

Theorem SubjectRed1 (Γ : Context) (t t' : Trm) (T : Typ) :
        ([Γ] ⊢ t ::: T) -> (t ↝₁ t') -> ([Γ] ⊢ t' ::: T)
.
Proof.
  intros H1 H2.
  revert Γ T H1.
  induction H2; auto;
  intros Γ T H1; inversion H1; subst;
  try (econstructor; eauto).
  + inversion H3; subst.
    apply IHRed1_1 in H4.
    apply IHRed1_2 in H5.
    set (W := Typed_Subst ε ε _ _ _ _ _ H5 H4); cbn in W.
    rewrite shift_O in W.
    trivial.
Qed.

Lemma unit_red1 (t : Trm) : (un ↝₁ t) -> t = un.
Proof.
  intros H.
  inversion H; auto.
Qed.

Hint Extern 1 =>
match goal with
  [H : un ↝₁ _ |- _] => apply unit_red1 in H; subst
end.

Lemma var_red1 (n : nat) (t : Trm) : (𝔳(n) ↝₁ t) -> t = 𝔳(n).
Proof.
  intros H.
  inversion H; auto.
Qed.

Hint Extern 1 =>
match goal with
  [H : 𝔳(_) ↝₁ _ |- _] => apply var_red1 in H; subst
end.

Lemma fun_red1 (t1 t2 : Trm) : ((λ t1) ↝₁ t2) -> {s : Trm & t2 = λ s & t1 ↝₁ s}.
Proof.
  intros H.
  inversion H; eexists; eauto.
Qed.

Hint Extern 1 =>
match goal with
  [H : (λ _) ↝₁ _ |- _] =>
  apply fun_red1 in H;
    let s := fresh "s" in
    let H1 := fresh "H" in
    let H2 := fresh "H2" in
    destruct H as [s H1 H2];
      subst
end.

Lemma subst_red1 (t1 t2 s1 s2: Trm) (l : nat) :
  (t1 ↝₁ s1) ->
  (t2 ↝₁ s2) ->
  (t1 [t2 // l]) ↝₁ (s1 [s2 // l])
.
Proof.
  intros H1 H2.
  revert s1 H1 t2 s2 l H2.
  induction t1; intros s1 H1 t2 s2 l H2; eauto.
   - apply var_red1 in H1; subst.
     cbn; destruct lt_eq_lt_dec as [[]|]; destruct n; auto.
   - apply fun_red1 in H1; destruct H1 as [v H1]; subst.
     constructor; fold subst.
     apply IHt1; eauto.
     admit.
   - cbn.
     inversion H1; subst; cbn in *; auto.
     + assert (G1 : λ t1 ↝₁ λ s0) by auto.
       specialize (IHt1_1 _ G1 _ _ l H2).
       inversion IHt1_1; subst.
       admit.
       admit.
Admitted.

Hint Resolve subst_red1.

Hint Extern 1 => match goal with [H : λ _ = λ _ |- _] => inversion H; subst end.

Theorem ChurchRosser1 (t s1 s2 : Trm) :
  (t ↝₁ s1) -> (t ↝₁ s2) -> {r : Trm & (s1 ↝₁ r) & (s2 ↝₁ r)}.
Proof.
  revert s1 s2.
  induction t; intros s1 s2 H1 H2; eauto.
  - inversion H1; subst; inversion H2; subst; eauto.
    match goal with
      [H1 : t ↝₁ _ , H2 : t ↝₁ _ |- _] =>
      destruct (IHt _ _ H1 H2); eauto
    end.
  - destruct t1;
    inversion H1; subst; inversion H2; subst; eauto;
    repeat match goal with
             [H1 : ?t ↝₁ ?s1 , H2 : ?t ↝₁ ?s2 |- _] =>
             (destruct (IHt1 _ _ H1 H2); clear H1 H2) +
             (destruct (IHt2 _ _ H1 H2); clear H1 H2) +
             (
               let H1' := fresh "H" in
               let H2' := fresh "H" in
               assert (H1' : (λ t) ↝₁ (λ s1)) by eauto;
                 assert (H2' : (λ t) ↝₁ (λ s2)) by eauto;
                 clear H1 H2;
                 (destruct (IHt1 _ _ H1' H2'); clear H1' H2')
             ) +
             (match goal with
                [H : λ _ ↝₁ ?s |- _] =>
                inversion H; subst; clear H
              end)
           end;
    eauto 7.
Qed.

Reserved Notation "s ↝* t" (at level 100, no associativity).

Inductive Red (t1 : Trm) (t3 : Trm) : Type :=
| Red_Red1 : (t1 ↝₁ t3) -> (t1 ↝* t3)
| Red_Trans : forall t2, (t1 ↝₁ t2) -> (t2 ↝* t3) -> (t1 ↝* t3)
where "s ↝* t" := (Red s t).

Hint Constructors Red.

Lemma Red_Trans' : forall t1 t2 t3, (t1 ↝* t2) -> (t2 ↝* t3) -> (t1 ↝* t3).
Proof.
  intros t1 t2 t3 H1.
  revert t3.
  induction H1; eauto.
Qed.

Hint Resolve Red_Trans'.

Theorem ChurchRosser1_many (t s1 s2 : Trm) :
  (t ↝₁ s1) -> (t ↝* s2) -> {r : Trm & (s1 ↝* r) & (s2 ↝* r)}.
Proof.
  intros H1 H2.
  assert (G : forall s, (t ↝₁ s) -> {r : Trm & (s1 ↝* r) & (s ↝₁ r)}).
  {
    intros s G.
    edestruct (ChurchRosser1 _ _ _ G H1); eauto.
  }
  {
    clear H1.
    induction H2 as [? ? H2|].
    - edestruct G; eauto.
    - apply IHRed.
      intros s H3.
      edestruct G as [s' G1 G2]; [eassumption|].
      edestruct (ChurchRosser1 _ _ _ H3 G2); eauto.
  }
Qed.

Theorem ChurchRosser (t s1 s2 : Trm) :
  (t ↝* s1) -> (t ↝* s2) -> {r : Trm & (s1 ↝* r) & (s2 ↝* r)}.
Proof.
  intros H1.
  revert s2.
  induction H1; eauto; intros s2 H2.
  - eapply ChurchRosser1_many; eauto.
  - edestruct ChurchRosser1_many; try eassumption.
    edestruct IHRed; eauto.
Qed.


Require Export Categories.

Class Isomorphism {C: Category} (x y : @obj C) : Type := {
  to   : arrow y x;
  from : arrow x y;

  iso_to_from : to o from = @identity C y;
  iso_from_to : from o to = @identity C x
}.

Arguments to {_ _ _} _.
Arguments from {_ _ _} _.

Lemma iso_split: forall C x y (I1 I2: Isomorphism x y),
        to I1 = to I2 /\ from I1 = @from C x y I2 -> I1 = I2.
Proof. intros.
       destruct H as (H1, H2).
       destruct I1, I2. simpl in *. subst.
       specialize (proof_irrelevance (to1 o from1 = identity y) iso_to_from0 iso_to_from1); intros.
       specialize (proof_irrelevance (from1 o to1 = identity x) iso_from_to0 iso_from_to1); intros.
       now subst.
Qed.

(** Groupoid is a category with all maps isomorphisms => category of isomorphisms *)
Definition Groupoid (C: Category): Category.
Proof. unshelve econstructor.
       - exact (@obj C).
       - exact Isomorphism.
       - intros. unshelve econstructor.
         + exact (identity a).
         + exact (identity a).
         + now rewrite f_identity.
         + now rewrite f_identity.
      - intros a b c I1 I2.
        unshelve econstructor.
        + destruct I1, I2. exact (to1 o to0).
        + destruct I1, I2. exact (from0 o from1).
        + simpl. destruct I1, I2. rewrite <- iso_to_from1.
          rewrite assoc. repeat apply compose_respects. rewrite <- assoc.
          now rewrite iso_to_from0, f_identity. easy.
        + simpl. destruct I1, I2. rewrite <- iso_from_to0.
          rewrite assoc. repeat apply compose_respects. rewrite <- assoc.
          now rewrite iso_from_to1, f_identity. easy.
      - repeat intro. simpl in *. subst. easy.
      - repeat intro. simpl. destruct f, g,  h. simpl in *.
        apply iso_split. simpl. split; now rewrite assoc.
      - intros. simpl. destruct f. simpl.
        apply iso_split. simpl. split. now rewrite f_identity.
        now rewrite identity_f.
      - intros. destruct f. apply iso_split. simpl.
        split. now rewrite identity_f.
        now rewrite f_identity.
Defined.
Check Groupoid.

Infix "≅" := Isomorphism (at level 40, left associativity).


Require Import List.

Theorem app_nil_r : forall (A : Type)(l : list A), l ++ nil = l.
Proof.
intros.
induction l.
reflexivity.
simpl.
apply (f_equal(cons a)).
apply IHl.
Qed.

Theorem app_assoc : forall (A : Type)(l1 l2 l3 : list A), l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
intros.
induction l1.
reflexivity.
simpl.
f_equal.
apply IHl1.
Qed.

Theorem rev_app_distr : forall (A : Type)(l1 l2 : list A), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
intros.
induction l1.
simpl.
rewrite app_nil_r.
reflexivity.
simpl.
rewrite app_assoc.
f_equal.
apply IHl1.
Qed.

Theorem rev_involutive : forall (A : Type)(l : list A), rev (rev l) = l.
Proof.
intros.
induction l.
reflexivity.
simpl.
rewrite rev_app_distr.
simpl.
f_equal.
apply IHl.
Qed.

Theorem fold_right_app :
  forall (A B : Type)(f : B -> A -> A)(l l' : list B)(i : A),
  fold_right f i (l ++ l') = fold_right f (fold_right f i l') l.
Proof.
intros.
induction l.
reflexivity.
simpl.
f_equal.
apply IHl.
Qed.


(* 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 *)
(* max is replaced with (ZArith.BinInt.Z.max x x1) by the coq driver *)

(* Why3 goal *)
Lemma max_def : forall (x:Z) (y:Z), ((y <= x)%Z ->
  ((ZArith.BinInt.Z.max x y) = x)) /\ ((~ (y <= x)%Z) ->
  ((ZArith.BinInt.Z.max x y) = y)).
Proof.
intros x y.
split ; intros H.
now apply Zmax_l.
apply Zmax_r.
omega.
Qed.

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

(* Why3 goal *)
Lemma min_def : forall (x:Z) (y:Z), ((y <= x)%Z ->
  ((ZArith.BinInt.Z.min x y) = y)) /\ ((~ (y <= x)%Z) ->
  ((ZArith.BinInt.Z.min x y) = x)).
Proof.
intros x y.
split ; intros H.
now apply Zmin_r.
apply Zmin_l.
omega.
Qed.

(* Why3 goal *)
Lemma Max_r : forall (x:Z) (y:Z), (x <= y)%Z ->
  ((ZArith.BinInt.Z.max x y) = y).
exact Zmax_r.
Qed.

(* Why3 goal *)
Lemma Min_l : forall (x:Z) (y:Z), (x <= y)%Z ->
  ((ZArith.BinInt.Z.min x y) = x).
exact Zmin_l.
Qed.

(* Why3 goal *)
Lemma Max_comm : forall (x:Z) (y:Z),
  ((ZArith.BinInt.Z.max x y) = (ZArith.BinInt.Z.max y x)).
exact Zmax_comm.
Qed.

(* Why3 goal *)
Lemma Min_comm : forall (x:Z) (y:Z),
  ((ZArith.BinInt.Z.min x y) = (ZArith.BinInt.Z.min y x)).
exact Zmin_comm.
Qed.

(* Why3 goal *)
Lemma Max_assoc : forall (x:Z) (y:Z) (z:Z),
  ((ZArith.BinInt.Z.max (ZArith.BinInt.Z.max x y) z) = (ZArith.BinInt.Z.max x (ZArith.BinInt.Z.max y z))).
Proof.
intros x y z.
apply eq_sym, Zmax_assoc.
Qed.

(* Why3 goal *)
Lemma Min_assoc : forall (x:Z) (y:Z) (z:Z),
  ((ZArith.BinInt.Z.min (ZArith.BinInt.Z.min x y) z) = (ZArith.BinInt.Z.min x (ZArith.BinInt.Z.min y z))).
Proof.
intros x y z.
apply eq_sym, Zmin_assoc.
Qed.


(******************************************************************************)
(*                                                                            *)
(*      LECTURE :  Floating-point numbers and formal proof                    *)
(*                       Laurent.Thery@inria.fr       12/05/2016              *)
(*                                                                            *)
(******************************************************************************)

(*
  After having seeen the rounding mode, we are going to see the formats for
  our floating point numbers. We start from a very generic representation
*)

Require Import Psatz ZArith Reals.
From Flocq Require Import FTZ Core Operations.

Open Scope R_scope.

Axiom todo : forall P, P.
Ltac todo := apply todo.

Section Lecture3.

Check radix.                                                   (* A basis     *)
Print radix.

Definition  radix2 : radix. exists  2%Z. auto. Defined.
Definition radix10 : radix. exists 10%Z. auto. Defined.

Print Coercion Paths radix Z.
Compute (radix2 + 2)%Z.

Check float.
Check float radix2.                                 (* Floating point number as
                                                       pair of integers       *)
Check float radix10.
Print float.

Definition val1 : float radix2  := {| Fnum := 7; Fexp := 1 |}.
Compute Fnum val1.
Compute Fexp val1.

Definition val2 : float radix2  := {| Fnum := 7; Fexp := 0 |}.
Compute Fnum val2.
Compute Fexp val2.

Definition val3 : float radix10 := {| Fnum := 7; Fexp := 10 |}.

Check F2R val1.                                   (* Converting float to real *)
Eval lazy beta delta [F2R] in F2R val1.
Compute F2R val1.
Compute F2R val2.
Compute F2R val3.

Variable r : radix.

(*
  Prove that the positivity of a floating point number is the one of its matissa

Fact ex1 : forall (f : float r), (0 <= Fnum f)%Z <->  0 <= F2R f.
Proof.
...
Qed.

*)

(******************************************************************************)
(*                            OPERATIONS                                      *)
(******************************************************************************)

Check Fopp val1.
Eval lazy beta delta [Fopp] in Fopp val1.
Compute Fopp val1.
Search Fopp.

Check Fabs val1.
Eval lazy beta delta [Fabs] in Fabs val1.
Compute Fabs val1.
Search Fabs.

Check Falign val1 val2.
Eval lazy beta delta [Falign] in Falign val1 val2.
Compute Falign val1 val2.
Search Falign.

Check Fplus val1 val2.
Eval lazy beta delta [Fplus] in Fplus val1 val2.
Compute Fplus val1 val2.
Search Fplus.

Check Fminus val1 val2.
Eval lazy beta delta [Fminus] in Fminus val1 val2.
Compute Fminus val1 val2.
Search Fminus.

Check Fmult val1 val2.
Eval lazy beta delta [Fmult] in Fmult val1 val2.
Compute Fmult val1 val2.
Search Fmult.

(******************************************************************************)
(*                               FORMATS                                      *)
(******************************************************************************)

Variable e : Z.                                 (* Bound on the exponent      *)
Variable p : Z.                                 (* Precision for the mantissa *)
Variables x y : R.

(* Format with a fixed exponent                                               *)
Check FIX_format r e x.
Check FIX_spec.

(*
  Prove that zero is in the FIX format and that this format is symmetric
*)
Fact ex2 : FIX_format r e 0.
Proof.
exists {| Fnum := 0; Fexp := e |}.
- unfold F2R.
  simpl.
  ring.
- simpl.
  trivial.
Qed.

Fact ex3 : FIX_format r e x -> FIX_format r e (- x).
Proof.
intros [f Hf].
exists (Fopp f).
- todo.
- todo.
Qed.

(* Format without bound on the exponent                                       *)
Check FLX_format r p x.
Check FLX_spec.

(*
  Prove that zero is in the FLX format and that this format is symmetric

Fact ex4 : (0 <= p)%Z ->  FLX_format r p 0.
Proof.
...
Qed.

Fact ex5 : FLX_format r p x -> FLX_format r p (- x).
Proof.
...
Qed.

*)

(* Format with normalised numbers but without bound on the exponent           *)
Check FLXN_format r p x.
Check FLXN_spec.

(*
  Prove that zero is in the FLXN format and that this format is symmetric

Fact ex6 : FLXN_format r p 0.
Proof.
...
Qed.

Fact ex7 : FLXN_format r p x -> FLXN_format r p (- x).
Proof.
...
Qed.

*)

(* Format with denormalised numbers and with bound on the exponent            *)
Check FLT_format r e p x.
Check FLT_spec.

(*
  Prove that zero is in the FLT format and that this format is symmetric

Fact ex8 : (0 <= p)%Z -> FLT_format r e p 0.
Proof.
...
Qed.

Fact ex9 : FLT_format r e p x -> FLT_format r e p (- x).
Proof.
...
Qed.

*)

(* Format without denormalised numbers but with bound on the exponent         *)

Check FTZ_format r e p x.
Check FTZ_spec.

(*
  Prove that zero is in the FTZ format and that this format is symmetric

Fact ex10 : (0 <= p)%Z -> FTZ_format r e p 0.
Proof.
...
Qed.

Fact ex11 : FTZ_format r e p x -> FTZ_format r e p (- x).
Proof.
...
Qed.

*)

(******************************************************************************)
(*                 A more algorithmic version                                 *)
(******************************************************************************)

Check bpow radix2 10.
Eval lazy beta delta [bpow] in bpow radix2 10.
Compute bpow radix2 10.

Check (mag r x).          (* An exponent and the proof of the bound  *)
Print mag.

Check mag r x.                 (* The logarithm associated to a real      *)
Print Coercion Paths mag_prop Z.
Check (mag r x + 2)%Z.
Check (bpow_mag_gt r x).       (* lemma for the upper bound               *)

Check archimed.                    (* Archimedian property                    *)
Check Zfloor.                      (* The floor function                      *)
Print Zfloor.
Check Zceil.                       (* The ceiling function                    *)
Print Zceil.
Check Ztrunc.                      (* The truncating function                 *)
Print Ztrunc.

Variable phi : Z -> Z.             (* translating exponent                    *)

Check cexp r phi x.
Eval lazy beta delta [cexp] in cexp r phi x.

Check scaled_mantissa r phi x.
Eval lazy beta delta [scaled_mantissa] in scaled_mantissa r phi x.

Check generic_format r phi x. (* Generic format that depends only on phi      *)
Eval lazy beta delta [generic_format] in generic_format r phi x.
Eval lazy beta delta [generic_format F2R Fnum Fexp] iota in
   generic_format r phi x.
Eval lazy beta delta [generic_format F2R scaled_mantissa Fnum Fexp] iota in
   generic_format r phi x.

(*
  Prove that the generic format contains zero and is symmetric
*)

Fact ex12 : generic_format r phi 0.
Proof.
unfold generic_format, F2R, scaled_mantissa; simpl.
todo.
Qed.

Fact ex13 : forall z,  z <> 0 -> mag r (- z) = mag r z :> Z.
Proof.
Search mag inside Raux.
todo.
Qed.

Fact ex14 : forall z, generic_format r phi z -> generic_format r phi (- z).
Proof.
intros z; unfold generic_format, scaled_mantissa, cexp, F2R; simpl.
todo.
Qed.

(*
Hint : we can rely on the following properties of Ztrunc and mag

Search Ztrunc inside Fcore_Raux.
Search mag inside Fcore_Raux.

*)

(* We can revisit the previous format using the algorithmic version           *)

Variable z : Z.

(* Format with fixed exponent                                                 *)
Check FIX_exp e z.
Eval lazy beta delta [FIX_exp] in FIX_exp e z.

Check generic_format_FIX r e x.
Check FIX_format_generic r e x.

(* Format without bound on the exponent                                       *)
Check FLX_exp p z.
Eval lazy beta delta [FLX_exp] in FLX_exp p z.

Check generic_format_FLX r p x.
Check FLX_format_generic r p x.

(* Format with denormalised numbers and with bound on the exponent            *)
Check FLT_exp e p z.
Eval lazy beta delta [FLT_exp] in FLT_exp e p z.

Check generic_format_FLT r e p x.
Check FLT_format_generic r e p x.

(* Format without denormalised numbers but with a bound on the exponent       *)
Check FTZ_exp e p z.
Eval lazy beta delta [FTZ_exp] in FTZ_exp e p z.

(*
  Prove Sterbenz lemma using the only property that phi is monotone

Fact ex15 :
  Monotone_exp phi ->
  generic_format r phi x -> generic_format r phi y ->
  (y / 2 <= x <= 2 * y)%R ->
  generic_format r phi (x - y)%R.
Proof.
...
Qed.

For this proof, we use the following lemma that gives a simple criterion to
ensure that a float is in the format

Check generic_format_F2R.

Here is the informal proof :
 From (y / 2 <= x <= 2 * y) we deduce that
    - 0 <= y       (1)
    - 0 <= x       (2)
    - x - y <= x   (3)
    - x - y <= y.  (4)
  generic_format r phi x can be rewritten as
    x = F2R {| Fnum := mx; Fexp := phi (mag r x) |}
  generic_format r phi y can be rewritten as
    y = F2R {| Fnum := my, Fexp := phi (mag r y) |}
  using Fopp, we can rewrite x - y as
    x - y =
     F2R {|Fnum := mz, Fexp := Z.min (phi (mag r x), phi (mag r y) |}
  so in order to have generic_format r phi (x - y) using  generic_format_F2R,
  it is sufficient that

   phi (mag r (x - y)) <= Z.min (phi (mag r x), phi (mag r y))

  so that

     phi (mag r (x - y)) <= phi (mag r x)
  and
     phi (mag r (x - y)) <= phi (mag r y)

  but mag is monotone so is phi, it is then sufficient to prove that

     x - y <= x
  and
     x - y <= y

  that come from (3) and (4).

*)

(* We can derive a generic rounding function                                  *)

Variable rnd : R -> Z.                           (* Rounding on the mantissa  *)

Check round r phi rnd x.
Eval lazy beta delta [round] in round r phi rnd x.

Check round r phi Zfloor x.                      (* Rounding down             *)
Eval lazy beta delta [round] in round r phi Zfloor x.

Check round r phi Zceil x.                       (* Rounding up               *)
Eval lazy beta delta [round] in round r phi Zfloor x.

Check round r phi Ztrunc x.                      (* Rounding to zero          *)
Eval lazy beta delta [round] in round r phi Ztrunc x.

Variable choice : Z -> bool.
Check round r phi (Znearest choice) x.
Eval lazy beta delta [round] in round r phi (Znearest choice) x.
Eval lazy beta delta [Znearest] in round r phi (Znearest choice) x.

(* Which conditions on phi for this rounding to have good properties?         *)

Print Valid_exp.
Variable vExp : Valid_exp phi.

Check @generic_format_satisfies_any r phi.
Check @round_DN_pt r phi.
Check @round_UP_pt r phi.
Check @round_ZR_pt r phi.
Check @round_N_pt r phi.

Print Valid_rnd.

Check valid_rnd_DN.
Check valid_rnd_UP.
Check valid_rnd_ZR.
Check valid_rnd_N choice.

(*
  Prove that the error resulting of an addition in rounded to the nearest
  can always be represented exactly

  We first prove a first general result on how a rounded value can be
  represented

  Fact ex16 :
    forall (f : float r) rnd, Valid_rnd rnd ->
    exists m',
      round r phi rnd (F2R f) =
      F2R ({| Fnum := m'; Fexp := Fexp f |} : float r).
  Proof.
  ...
  Qed.

  Informal proof
    we can rewrite the rounded value as:

     round r phi rnd (F2R f) =
       F2R {| Fnum := m; Fexp := phi (mag r (Fexp f)) |}

     if phi (mag r (Fexp f)) <= Fexp f

       we can choose m' = (Fnum f)

    if phi (mag r (Fexp f)) > Fexp f

       we can choose m' = m * r ^ (phi (mag r (Fexp f)) - Fexp f).

  Fact ex17 :
    Monotone_exp phi ->
    generic_format r phi x -> generic_format r phi y ->
    generic_format r phi (round r phi (Znearest choice) (x + y) - (x + y))%R.
  Proof.
  ....
  Qed.

  Informal proof

  generic_format r phi x can be rewritten as
    x  = F2R {| Fnum := mx; Fexp := phi (mag r x) |}

  generic_format r phi y, can be rewritten as
    y  = F2R {| Fnum := my; Fexp := phi (mag r y) |}

  without loss of generality we can suppose that
        phi (mag r x) <= phi (mag r y)

  so using Fplus we have
    x + y = F2R {| Fnum := mx +
                           my * r ^ (phi (mag r y) - phi (mag r x));
                   Fexp := phi (mag x) |}

  applyin ex16 we get
    round r phi (Znearest choice) (F2R (x + y)) =
            F2R {| Fnum := m; Fexp := phi (mag r x) |}

  the definition of Fopp gives
    round r phi (Znearest choice) (x + y) - (x + y) =
       F2R {| Fnum := m - mx + my * r ^ (phi (mag r y) - phi (mag r x));
              Fexp := phi (mag r x) |}

  using  generic_format_F2R, a sufficient condition for this float to be in
  the format is :

    phi (mag r (round r phi (Znearest choice) (x + y) - (x + y))) <=
    phi (mag r x)

   phi and mag are monotone so it is sufficient that

    |round r phi (Znearest choice) (x + y) - (x + y))| <= |x|

   so

    |round r phi (Znearest choice) (x + y) - (x + y))| <= |y - (x + y)|

  but y is a float so its distance to x + y must be greater or equal to the one
  of the rounded value to the nearest of x + y.

*)

End Lecture3.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Diagonal.
Require Import Category.Structure.Cone.

Generalizable All Variables.

(* A natural transformation Δd ⟹ F (where Δd is the Constant functor on d) is
   the same as a cone over F (whose vertex is d). *)

Monomorphic Theorem Cone_Transform `(F : J ⟶ C) (d : C) :
  Δ[J](d) ⟹ F ↔ { c : Cone F | vertex_obj = d }.
Proof.
  split; intros.
  - unshelve eexists.
    + unshelve econstructor; intros; [ exact d | unshelve econstructor ].
      * apply X.
      * abstract(simpl; intros;
        rewrite (naturality[X]); cat).
    + reflexivity.
  - transform; simpl; intros;
    destruct X; subst.
    + apply x0.
    + cat; apply cone_coherence.
    + cat; symmetry; apply cone_coherence.
Defined.


(* Coq assignment - LDI 2018

Prove the lemmas given below (and replace Admitted with Qed).

It is not allowed to:
1. import other modules than List,
2. define Ltac tactics,
3. erase statements of the lemma (if you fail to prove a lemma leave Admitted).

It is allowed to:

1. introduce your own definitions and auxiliary lemmas,
2. change the order of the lemmas to prove,
3. add comments.

Remember about revert/generalize tactics.
*)

Require Import List.
Set Implicit Arguments.

Section Zal.

Check list.
Print list.

Variable A: Type.

Inductive podciag : list A -> list A -> Prop :=
| PC_Nil : forall l, podciag nil l
| PC_ConsH : forall a l1 l2, podciag l1 l2 -> podciag (cons a l1) (cons a l2)
| PC_ConsT : forall a l1 l2, podciag l1 l2 -> podciag l1 (cons a l2).

Inductive prefix : list A -> list A -> Prop :=
| P_Nil : forall l, prefix nil l
| P_Cons : forall a l1 l2, prefix l1 l2 -> prefix (cons a l1) (cons a l2).

Inductive sufix : list A -> list A -> Prop :=
| S_Nil : forall l, sufix l l
| S_Cons : forall a l1 l2, sufix l1 l2 -> sufix l1 (cons a l2).

Inductive podlista : list A -> list A -> Prop :=
| PL_Base : forall l1 l2, prefix l1 l2 -> podlista l1 l2
| PL_Cons : forall a l1 l2, podlista l1 l2 -> podlista l1 (cons a l2).

Lemma Prefix_Podlista : forall l1 l2, prefix l1 l2 -> podlista l1 l2.
Proof.
Admitted.

Lemma Sufix_Podlista : forall l1 l2, sufix l1 l2 -> podlista l1 l2.
Proof.
Admitted.

Lemma Prefix_Podciag : forall l1 l2, prefix l1 l2 -> podciag l1 l2.
Proof.
Admitted.

Lemma Podlista_Podciag: forall l1 l2, podlista l1 l2 -> podciag l1 l2.
Proof.
Admitted.

Lemma Append_Podciag_Podciag_Podciag:
      forall p1 l1 p2 l2, podciag p1 l1 -> podciag p2 l2
       -> podciag (p1 ++ p2) (l1 ++ l2).
Proof.
Admitted.

Lemma Append_Eq_Prefix_Prefix:
      forall l p2 l2, prefix p2 l2 -> prefix (l ++ p2)(l ++ l2).
Proof.
Admitted.

Lemma Append_Sufix_Prefix_Podlista:
      forall p1 l1 p2 l2, sufix p1 l1 -> prefix p2 l2
       -> podlista (p1 ++ p2) (l1 ++ l2).
Proof.
Admitted.

Definition sufixD (s l : list A):= exists p, p ++ s = l.

Lemma Sufix_SufixD: forall s l, sufix s l <-> sufixD s l.
Proof.
Admitted.

Lemma Sufix_Prefix: forall s l, sufix s l -> exists p, prefix p l /\ p ++ s = l.
Proof.
Admitted.

Lemma Trans_Podciag: forall l1 l2 l3, podciag l1 l2 -> podciag l2 l3 -> podciag l1 l3.
Proof.
Admitted.

End Zal.


(**
  This module defines the Ring record type which can be used to
  represent algebraic rings and provides a collection of axioms
  and theorems describing them.

  Copyright (C) 2018 Larry D. Lee Jr. <llee454@gmail.com>

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

  This program 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 program. If not, see
  <https://www.gnu.org/licenses/>.
*)

Require Import Description.
Require Import FunctionalExtensionality.
Require Import base.
Require Import function.
Require Import monoid.
Require Import group.
Require Import abelian_group.

Module Ring.

Close Scope nat_scope.

(**
  Accepts two binary functions, f and g, and
  asserts that f is left distributive over g.
*)
Definition is_distrib_l (T : Type) (f g : T -> T -> T)
  :  Prop
  := forall x y z : T, f x (g y z) = g (f x y) (f x z).

(**
  Accepts two binary functions, f and g, and
  asserts that f is right distributive over g.
*)
Definition is_distrib_r (T : Type) (f g : T -> T -> T)
  :  Prop
  := forall x y z : T, f (g y z) x = g (f y x) (f z x).

(**
  Accepts two binary functions, f and g, and
  asserts that f is distributive over g.
*)
Definition is_distrib (T : Type) (f g : T -> T -> T)
  :  Prop
  := is_distrib_l T f g /\ is_distrib_r T f g.

(** Represents algebraic rings *)
Structure Ring : Type := ring {

  (** Represents the set of ring elements. *)
  E : Set;

  (** Represents 0 - the additive identity. *)
  E_0 : E;

  (** Represents 1 - the multiplicative identity. *)
  E_1 : E;

  (** Represents addition. *)
  sum : E -> E -> E;

  (** Represents multiplication. *)
  prod : E -> E -> E;

  (** Asserts that 0 /= 1. *)
  distinct_0_1 : E_0 <> E_1;

  (** Asserts that addition is associative. *)
  sum_is_assoc : Monoid.is_assoc E sum;

  (** Asserts that addition is commutative. *)
  sum_is_comm : Abelian_Group.is_comm E sum;

  (** Asserts that E_0 is the left identity element. *)
  sum_id_l : Monoid.is_id_l E sum E_0;

  (**
    Asserts that every element has an additive
    inverse.
  *)
  sum_inv_l_ex : forall x : E, exists y : E, sum y x = E_0;

  (** Asserts that multiplication is associative. *)
  prod_is_assoc : Monoid.is_assoc E prod;

  (**
    Asserts that 1 is the left identity
    element.
  *)
  prod_id_l : Monoid.is_id_l E prod E_1;

  (**
    Asserts that 1 is the right identity
    element.
  *)
  prod_id_r : Monoid.is_id_r E prod E_1;

  (**
    Asserts that multiplication is left
    distributive over addition.
  *)
  prod_sum_distrib_l : is_distrib_l E prod sum;

  (**
    Asserts that multiplication is right
    distributive over addition.
  *)
  prod_sum_distrib_r : is_distrib_r E prod sum
}.

(** Enable implicit arguments for ring properties. *)

Arguments E_0 {r}.

Arguments E_1 {r}.

Arguments sum {r} x y.

Arguments prod {r} x y.

Arguments distinct_0_1 {r} _.

Arguments sum_is_assoc {r} x y z.

Arguments sum_is_comm {r} x y.

Arguments sum_id_l {r} x.

Arguments sum_inv_l_ex {r} x.

Arguments prod_is_assoc {r} x y z.

Arguments prod_id_l {r} x.

Arguments prod_id_r {r} x.

Arguments prod_sum_distrib_l {r} x y z.

Arguments prod_sum_distrib_r {r} x y z.

(** Define notations for ring properties. *)

Notation "0" := E_0 : ring_scope.

Notation "1" := E_1 : ring_scope.

Notation "x + y" := (sum x y) (at level 50, left associativity) : ring_scope.

Notation "{+}" := sum : ring_scope.

Notation "x # y" := (prod x y) (at level 50, left associativity) : ring_scope.

Notation "{#}" := prod : ring_scope.

Open Scope ring_scope.

Section Theorems.

(**
  Represents an arbitrary ring.

  Note: we use Variable rather than Parameter
  to ensure that the following theorems are
  generalized w.r.t r.
*)
Variable r : Ring.

(**
  Represents the set of group elements.

  Note: We use Let to define E as a
  local abbreviation.
*)
Let E := E r.

(**
  A predicate that accepts one element, x,
  and asserts that x is nonzero.
*)
Definition nonzero (x : E) : Prop := x <> 0.

(**
  Accepts one ring element, x, and asserts
  that x is the left identity element.
*)
Definition sum_is_id_l := Monoid.is_id_l E sum.

(**
  Accepts one ring element, x, and asserts
  that x is the right identity element.
*)
Definition sum_is_id_r := Monoid.is_id_r E sum.

(**
  Accepts one ring element, x, and asserts
  that x is the identity element.
*)
Definition sum_is_id := Monoid.is_id E sum.

(**
  Represents the abelian group formed by
  addition over E.
*)
Definition sum_abelian_group
  := Abelian_Group.abelian_group E 0 {+} sum_is_assoc sum_is_comm sum_id_l sum_inv_l_ex.

(**
  Represents the group formed by addition
  over E.
*)
Definition sum_group
  := Abelian_Group.op_group sum_abelian_group.

(**
  Represents the monoid formed by addition
  over E.
*)
Definition sum_monoid
  := Abelian_Group.op_monoid sum_abelian_group.

(** Proves that 0 is the right identity element. *)
Theorem sum_id_r
  :  sum_is_id_r 0.
Proof Abelian_Group.op_id_r sum_abelian_group.

(** Proves that 0 is the identity element. *)
Theorem sum_id
  :  sum_is_id 0.
Proof Abelian_Group.op_id sum_abelian_group.

(**
  Accepts two elements, x and y, and
  asserts that y is x's left inverse.
*)
Definition sum_is_inv_l
  := Abelian_Group.op_is_inv_l sum_abelian_group.

(**
  Accepts two elements, x and y, and
  asserts that y is x's right inverse.
*)
Definition sum_is_inv_r
  := Abelian_Group.op_is_inv_r sum_abelian_group.

(**
  Accepts two elements, x and y, and
  asserts that y is x's inverse.
*)
Definition sum_is_inv
  := Abelian_Group.op_is_inv sum_abelian_group.

(**
  Accepts one argument, x, and asserts that
  x has a left inverse.
*)
Definition sum_has_inv_l := Abelian_Group.has_inv_l sum_abelian_group.

(**
  Accepts one argument, x, and asserts that
  x has a right inverse.
*)
Definition sum_has_inv_r := Abelian_Group.has_inv_r sum_abelian_group.

(**
  Accepts one argument, x, and asserts that
  x has an inverse.
*)
Definition sum_has_inv := Abelian_Group.has_inv sum_abelian_group.

(** Asserts that every element has a right inverse. *)
Theorem sum_inv_r_ex
  :  forall x : E, exists y : E, sum_is_inv_r x y.
Proof Abelian_Group.op_inv_r_ex sum_abelian_group.

(** Proves that the left identity element is unique. *)
Theorem sum_id_l_uniq
  :  forall x : E, Monoid.is_id_l E {+} x -> x = 0.
Proof Abelian_Group.op_id_l_uniq sum_abelian_group.

(** Proves that the right identity element is unique. *)
Theorem sum_id_r_uniq
  :  forall x : E, Monoid.is_id_r E {+} x -> x = 0.
Proof Abelian_Group.op_id_r_uniq sum_abelian_group.

(** Proves that the identity element is unique. *)
Theorem sum_id_uniq
  :  forall x : E, Monoid.is_id E {+} x -> x = 0.
Proof Abelian_Group.op_id_uniq sum_abelian_group.

(**
  Proves that for every group element, x,
  its left and right inverses are equal.
*)
Theorem sum_inv_l_r_eq
  :  forall x y : E, sum_is_inv_l x y -> forall z : E, sum_is_inv_r x z -> y = z.
Proof Abelian_Group.op_inv_l_r_eq sum_abelian_group.

(**
  Proves that the inverse relation is
  symmetrical.
*)
Theorem sum_inv_sym
  :  forall x y : E, sum_is_inv x y <-> sum_is_inv y x.
Proof Abelian_Group.op_inv_sym sum_abelian_group.

(** Proves that an element's inverse is unique. *)
Theorem sum_inv_uniq
  :  forall x y z :  E, sum_is_inv x y -> sum_is_inv x z -> z = y.
Proof Abelian_Group.op_inv_uniq sum_abelian_group.

(**
  Proves that every group element has an
  inverse.
*)
Theorem sum_inv_ex
  :  forall x : E, exists y : E, sum_is_inv x y.
Proof Abelian_Group.op_inv_ex sum_abelian_group.

(**
  Proves explicitly that every element has a
  unique inverse.
*)
Theorem sum_inv_uniq_ex
  :  forall x : E, exists! y : E, sum_is_inv x y.
Proof Abelian_Group.op_inv_uniq_ex sum_abelian_group.

(** Proves the left introduction rule. *)
Theorem sum_intro_l
  :  forall x y z : E, x = y -> z + x = z + y.
Proof Abelian_Group.op_intro_l sum_abelian_group.

(** Proves the right introduction rule. *)
Theorem sum_intro_r
  :  forall x y z : E, x = y -> x + z = y + z.
Proof Abelian_Group.op_intro_r sum_abelian_group.

(** Proves the left cancellation rule. *)
Theorem sum_cancel_l
  :   forall x y z : E, z + x = z + y -> x = y.
Proof Abelian_Group.op_cancel_l sum_abelian_group.

(** Proves the right cancellation rule. *)
Theorem sum_cancel_r
  :   forall x y z : E, x + z = y + z -> x = y.
Proof Abelian_Group.op_cancel_r sum_abelian_group.

(**
  Proves that an element's left inverse
  is unique.
*)
Theorem sum_inv_l_uniq
  :  forall x y z : E, sum_is_inv_l x y -> sum_is_inv_l x z -> z = y.
Proof Abelian_Group.op_inv_l_uniq sum_abelian_group.

(**
  Proves that an element's right inverse
  is unique.
*)
Theorem sum_inv_r_uniq
  :  forall x y z : E, sum_is_inv_r x y -> sum_is_inv_r x z -> z = y.
Proof Abelian_Group.op_inv_r_uniq sum_abelian_group.

(**
  Proves that 0 is its own left additive
  inverse.
*)
Theorem sum_0_inv_l
  :  sum_is_inv_l 0 0.
Proof Abelian_Group.op_inv_0_l sum_abelian_group.

(**
  Proves that 0 is its own right additive
  inverse.
*)
Theorem sum_0_inv_r
  :  sum_is_inv_r 0 0.
Proof Abelian_Group.op_inv_0_r sum_abelian_group.

(** Proves that 0 is it's own additive inverse. *)
Theorem sum_0_inv
  :  sum_is_inv 0 0.
Proof Abelian_Group.op_inv_0 sum_abelian_group.

(**
  Proves that the identity element has a
  left inverse.
*)
Theorem sum_has_inv_l_0
  :  sum_has_inv_l 0.
Proof Abelian_Group.op_has_inv_l_0 sum_abelian_group.

(**
  Proves that the identity element has a
  right inverse.
*)
Theorem sum_has_inv_r_0
  :  sum_has_inv_r 0.
Proof Abelian_Group.op_has_inv_r_0 sum_abelian_group.

(**
  Proves that the identity element has an
  inverse.
*)
Theorem sum_has_inv_0
  :  sum_has_inv 0.
Proof Abelian_Group.op_has_inv_0 sum_abelian_group.

(**
  Proves that if an element's, x, inverse
  equals 0, x equals 0.
*)
Theorem sum_inv_0_eq_0
  :  forall x : E, sum_is_inv x 0 -> x = 0.
Proof Abelian_Group.op_inv_0_eq_0 sum_abelian_group.

(**
  Proves that 0 is the only element whose
  additive inverse is 0.
*)
Theorem sum_inv_0_uniq
  :  unique (fun x => sum_is_inv x 0) 0.
Proof Abelian_Group.op_inv_0_uniq sum_abelian_group.

(** Represents strongly-specified negation. *)
Definition sum_neg_strong
  :  forall x : E, { y | sum_is_inv x y }
  := Abelian_Group.op_neg_strong sum_abelian_group.

(** Represents negation. *)
Definition sum_neg
  :  E -> E
  := Abelian_Group.op_neg sum_abelian_group.

Notation "{-}" := (sum_neg) : ring_scope.

Notation "- x" := (sum_neg x) : ring_scope.

(**
  Asserts that the negation returns the inverse
  of its argument.
*)
Definition sum_neg_def
  :  forall x : E, sum_is_inv x (- x)
  := Abelian_Group.op_neg_def sum_abelian_group.

(** Proves that negation is one-to-one *)
Definition sum_neg_inj
  :  is_injective E E {-}
  := Abelian_Group.op_neg_inj sum_abelian_group.

(** Proves the cancellation property for negation. *)
Theorem sum_cancel_neg
  :  forall x : E, - (- x) = x.
Proof Abelian_Group.op_cancel_neg sum_abelian_group.

(** Proves that negation is onto *)
Theorem sum_neg_onto
  :  is_onto E E {-}.
Proof Abelian_Group.op_neg_onto sum_abelian_group.

(** Proves that negation is surjective *)
Theorem sum_neg_bijective
  :  is_bijective E E {-}.
Proof Abelian_Group.op_neg_bijective sum_abelian_group.

(** Proves that neg x = y -> neg y = x *)
Theorem sum_neg_rev
  :  forall x y : E, - x = y -> - y = x.
Proof Abelian_Group.op_neg_rev sum_abelian_group.

(**
  Proves that the left inverse of x + y is -y + -x.
*)
Theorem sum_neg_distrib_inv_l
  :  forall x y : E, sum_is_inv_l (x + y) (- y + - x).
Proof Abelian_Group.op_neg_distrib_inv_l sum_abelian_group.

(**
  Proves that the right inverse of x + y is -y + -x.
*)
Theorem sum_neg_distrib_inv_r
  :  forall x y : E, sum_is_inv_r (x + y) (- y + - x).
Proof Abelian_Group.op_neg_distrib_inv_r sum_abelian_group.

(**
  Proves that the inverse of x + y is -y + -x.
*)
Theorem sum_neg_distrib_inv
  :  forall x y : E, sum_is_inv (x + y) (- y + - x).
Proof Abelian_Group.op_neg_distrib_inv sum_abelian_group.

(**
  Proves that negation is distributive: i.e.
  -(x + y) = -y + -x.
*)
Theorem sum_neg_distrib
  :  forall x y : E, - (x + y) = - y + - x.
Proof Abelian_Group.op_neg_distrib sum_abelian_group.

(** Proves that 0's negation is 0. *)
Theorem sum_0_neg
  :  - 0 = 0.
Proof
  proj2 (sum_neg_def 0)
  || a = 0 @a by <- sum_id_l (- 0).

(**
  Proves that if an element's, x, negation
  equals 0, x must equal 0.
*)
Theorem sum_neg_0
  :  forall x : E, - x = 0 -> x = 0.
Proof
  fun x H
    => proj2 (sum_neg_def x)
      || x + a = 0 @a by <- H
      || a = 0     @a by <- sum_id_r x.

(**
  Prove that 0 is the only element whose additive
  inverse (negation) equals 0.
*)
Theorem sum_neg_0_uniq
  :  unique (fun x => - x = 0) 0.
Proof
  conj sum_0_neg
    (fun x H => eq_sym (sum_neg_0 x H)).

(**
  Accepts one element, x, and asserts
  that x is the left identity element.
*)
Definition prod_is_id_l := Monoid.is_id_l E prod.

(**
  Accepts one element, x, and asserts
  that x is the right identity element.
*)
Definition prod_is_id_r := Monoid.is_id_r E prod.

(**
  Accepts one element, x, and asserts
  that x is the identity element.
*)
Definition prod_is_id := Monoid.is_id E prod.

(** Represents the monoid formed by op over E. *)
Definition prod_monoid := Monoid.monoid E 1 {#} prod_is_assoc prod_id_l prod_id_r.

(** Proves that 1 is the identity element. *)
Theorem prod_id
  :  prod_is_id 1.
Proof Monoid.op_id prod_monoid.

(** Proves that the left identity element is unique. *)
Theorem prod_id_l_uniq
  :  forall x : E, (Monoid.is_id_l E prod x) -> x = 1.
Proof Monoid.op_id_l_uniq prod_monoid.

(** Proves that the right identity element is unique. *)
Theorem prod_id_r_uniq
  :  forall x : E, (Monoid.is_id_r E prod x) -> x = 1.
Proof Monoid.op_id_r_uniq prod_monoid.

(** Proves that the identity element is unique. *)
Theorem prod_id_uniq
  :  forall x : E, (Monoid.is_id E prod x) -> x = 1.
Proof Monoid.op_id_uniq prod_monoid.

(** Proves the left introduction rule. *)
Theorem prod_intro_l
  :  forall x y z : E, x = y -> z # x = z # y.
Proof Monoid.op_intro_l prod_monoid.

(** Proves the right introduction rule. *)
Theorem prod_intro_r
  :  forall x y z : E, x = y -> x # z = y # z.
Proof Monoid.op_intro_r prod_monoid.

(**
  Accepts two elements, x and y, and
  asserts that y is x's left inverse.
*)
Definition prod_is_inv_l := Monoid.op_is_inv_l prod_monoid.

(**
  Accepts two elements, x and y, and
  asserts that y is x's right inverse.
*)
Definition prod_is_inv_r := Monoid.op_is_inv_r prod_monoid.

(**
  Accepts two elements, x and y, and
  asserts that y is x's inverse.
*)
Definition prod_is_inv := Monoid.op_is_inv prod_monoid.

(**
  Accepts one argument, x, and asserts that
  x has a left inverse.
*)
Definition prod_has_inv_l := Monoid.has_inv_l prod_monoid.

(**
  Accepts one argument, x, and asserts that
  x has a right inverse.
*)
Definition prod_has_inv_r := Monoid.has_inv_r prod_monoid.

(**
  Accepts one argument, x, and asserts that
  x has an inverse.
*)
Definition prod_has_inv := Monoid.has_inv prod_monoid.

(**
  Proves that the left and right inverses of
  an element must be equal.
*)
Theorem prod_inv_l_r_eq
  :  forall x y : E, prod_is_inv_l x y -> forall z : E, prod_is_inv_r x z -> y = z.
Proof Monoid.op_inv_l_r_eq prod_monoid.

(**
  Proves that the inverse relationship is
  symmetric.
*)
Theorem prod_inv_sym
  :  forall x y : E, prod_is_inv x y <-> prod_is_inv y x.
Proof Monoid.op_inv_sym prod_monoid.

(**
  Proves the left cancellation law for elements
  possessing a left inverse.
*)
Theorem prod_cancel_l
  :  forall x y z : E, prod_has_inv_l z -> z # x = z # y -> x = y.
Proof Monoid.op_cancel_l prod_monoid.

(**
  Proves the right cancellation law for
  elements possessing a right inverse.
*)
Theorem prod_cancel_r
  :  forall x y z : E, prod_has_inv_r z -> x # z = y # z -> x = y.
Proof Monoid.op_cancel_r prod_monoid.

(**
  Proves that an element's left inverse
  is unique.
*)
Theorem prod_inv_l_uniq
  :  forall x : E, prod_has_inv_r x -> forall y z : E, prod_is_inv_l x y -> prod_is_inv_l x z -> z = y.
Proof Monoid.op_inv_l_uniq prod_monoid.

(**
  Proves that an element's right inverse
  is unique.
*)
Theorem prod_inv_r_uniq
  :  forall x : E, prod_has_inv_l x -> forall y z : E, prod_is_inv_r x y -> prod_is_inv_r x z -> z = y.
Proof Monoid.op_inv_r_uniq prod_monoid.

(**
  Proves that an element's inverse is unique.

  Note: this theorem is defined as transparent to
  allow a theorem in the field module to compile.
*)
Definition prod_inv_uniq
  :  forall x y z : E, prod_is_inv x y -> prod_is_inv x z -> z = y
  := Monoid.op_inv_uniq prod_monoid.

(**
  Proves that the identity element is its own
  left inverse.
*)
Theorem prod_inv_1_l
  :  prod_is_inv_l 1 1.
Proof Monoid.op_inv_0_l prod_monoid.

(**
  Proves that the identity element is its own
  right inverse.
*)
Theorem prod_inv_1_r
  :  prod_is_inv_r 1 1.
Proof Monoid.op_inv_0_l prod_monoid.

(**
  Proves that the identity element is its own
  inverse.
*)
Theorem prod_inv_1
  :  prod_is_inv 1 1.
Proof Monoid.op_inv_0 prod_monoid.

(** Proves that 1 has a left multiplicative inverse. *)
Theorem prod_has_inv_l_1
  :  prod_has_inv_l 1.
Proof Monoid.op_has_inv_l_0 prod_monoid.

(** Proves that 1 has a right multiplicative inverse. *)
Theorem prod_has_inv_r_1
  :  prod_has_inv_r 1.
Proof Monoid.op_has_inv_r_0 prod_monoid.

(** Proves that 1 has a reciprical *)
Theorem prod_has_inv_1
  :  prod_has_inv 1.
Proof Monoid.op_has_inv_0 prod_monoid.

(**
  Proves that if an element's, x, inverse
  equals 0, x equals 0.
*)
Theorem prod_inv_1_eq_1
  :  forall x : E, prod_is_inv x 1 -> x = 1.
Proof Monoid.op_inv_0_eq_0 prod_monoid.

(**
  Proves that 0 is the only element whose
  inverse is 0.
*)
Theorem prod_inv_1_uniq
  :  unique (fun x => prod_is_inv x 1) 1.
Proof Monoid.op_inv_0_uniq prod_monoid.

(** Proves that 1 is its own left multiplicative inverse. *)
Theorem recipr_1_l
  :  prod_is_inv_l 1 1.
Proof Monoid.op_inv_0_l prod_monoid.

(** Proves that 1 is its own right multiplicative inverse. *)
Theorem recipr_1_r
  :  prod_is_inv_r 1 1.
Proof Monoid.op_inv_0_r prod_monoid.

(** Proves that 1 is its own recriprical. *)
Theorem recipr_1
  :  prod_is_inv 1 1.
Proof Monoid.op_inv_0 prod_monoid.

(** TODO Reciprical functions (op_neg) from Monoid. *)

(**
  Asserts that multiplication is
  distributive over addition.
*)
Theorem prod_sum_distrib
  :  is_distrib E prod sum.
Proof conj prod_sum_distrib_l prod_sum_distrib_r.

(**
  Proves that 0 times every number equals 0.

  0 x = 0 x
  (0 + 0) x = 0 x
  0 x + 0 x = 0 x
        0 x = 0
*)
Theorem prod_0_l
  :  forall x : E, 0 # x = 0.
Proof
  fun x
    => let H
         : (0 # x) + (0 # x) = (0 # x) + 0
         := eq_refl (0 # x)
           || a # x = 0 # x         @a by (sum_id_l 0)
           || a = 0 # x             @a by <- prod_sum_distrib_r x 0 0
           || (0 # x) + (0 # x) = a @a by sum_id_r (0 # x)
       in sum_cancel_l (0 # x) 0 (0 # x) H.

(** Proves that 0 times every number equals 0. *)
Theorem prod_0_r
  :  forall x : E, x # 0 = 0.
Proof
  fun x
    => let H
         :  (x # 0) + (x # 0) = 0 + (x # 0)
         := eq_refl (x # 0)
           || x # a = x # 0         @a by sum_id_r 0
           || a = x # 0             @a by <- prod_sum_distrib_l x 0 0
           || (x # 0) + (x # 0) = a @a by sum_id_l (x # 0)
       in sum_cancel_r (x # 0) 0 (x # 0) H.

(**
  Proves that 0 does not have a left
  multiplicative inverse.
*)
Theorem prod_0_inv_l
  :  ~ prod_has_inv_l 0.
Proof
  ex_ind
    (fun x (H : x # 0 = 1)
      => distinct_0_1 (H || a = 1 @a by <- prod_0_r x)).

(**
  Proves that 0 does not have a right
  multiplicative inverse.
*)
Theorem prod_0_inv_r
  :  ~ prod_has_inv_r 0.
Proof
  ex_ind
    (fun x (H : 0 # x = 1)
      => distinct_0_1 (H || a = 1 @a by <- prod_0_l x)).

(**
  Proves that 0 does not have a multiplicative
  inverse - I.E. 0 does not have a
  reciprocal.
*)
Theorem prod_0_inv
  :  ~ prod_has_inv 0.
Proof
  ex_ind
    (fun x H
      => prod_0_inv_l
           (ex_intro
             (fun x
                => prod_is_inv_l 0 x)
             x (proj1 H))).

(**
  Proves that multiplicative inverses, when
  they exist are always nonzero.
*)
Theorem prod_inv_0
  :  forall x y : E, prod_is_inv x y -> nonzero y.
Proof
  fun x y H (H0 : y = 0)
    => distinct_0_1
         (proj1 H
          || a # x = 1 @a by <- H0
          || a = 1     @a by <- prod_0_l x).

(** Represents -1 and proves that it exists. *)
Definition E_n1_strong
  :  { x : E | sum_is_inv 1 x }
  := constructive_definite_description (sum_is_inv 1) (sum_inv_uniq_ex 1).

(** Represents -1. *)
Definition E_n1 : E := proj1_sig E_n1_strong.

(**
  Defines a symbolic representation for -1

  Note: here we represent the inverse of 1
  rather than the negation of 1. Letter we prove
  that the negation equals the inverse.

  Note: brackets are needed to ensure Coq parses
  the symbol as a single token instead of a
  prefixed function call.
*)
Notation "{-1}" := E_n1 : ring_scope.

(** Asserts that -1 is the additive inverse of 1. *)
Theorem E_n1_def
  :  sum_is_inv 1 {-1}.
Proof proj2_sig E_n1_strong.

(** Asserts that -1 is the left inverse of 1. *)
Theorem E_n1_inv_l
  :  sum_is_inv_l 1 {-1}.
Proof proj1 E_n1_def.

(** Asserts that -1 is the right inverse of 1. *)
Theorem E_n1_inv_r
  :  sum_is_inv_r 1 {-1}.
Proof proj2 E_n1_def.

(**
  Asserts that every additive inverse
  of 1 must be equal to -1.
*)
Theorem E_n1_uniq
  :  forall x : E, sum_is_inv 1 x -> x = {-1}.
Proof fun x => sum_inv_uniq 1 {-1} x E_n1_def.

(**
  Proves that -1 * x equals the multiplicative
  inverse of x.

  -1 x + x = 0
  -1 x + 1 x = 0
  (-1 + 1) x = 0
  0 x = 0
  0 = 0
*)
Theorem prod_n1_x_inv_l
  :  forall x : E, sum_is_inv_l x ({-1} # x).
Proof
  fun x
    => prod_0_l x
       || a # x = 0          @a by E_n1_inv_l
       || a = 0              @a by <- prod_sum_distrib_r x {-1} 1
       || ({-1} # x) + a = 0 @a by <- prod_id_l x.

(**
  Proves that x * -1 equals the multiplicative
  inverse of x.

  x -1 + x = 0
*)
Theorem prod_x_n1_inv_l
  :  forall x : E, sum_is_inv_l x (x # {-1}).
Proof
  fun x
    => prod_0_r x
       || x # a = 0          @a by E_n1_inv_l
       || a = 0              @a by <- prod_sum_distrib_l x {-1} 1
       || (x # {-1}) + a = 0 @a by <- prod_id_r x.

(** Proves that x + -1 x = 0. *)
Theorem prod_n1_x_inv_r
  :  forall x : E, sum_is_inv_r x ({-1} # x).
Proof
  fun x
    => prod_0_l x
       || a # x = 0          @a by E_n1_inv_r
       || a = 0              @a by <- prod_sum_distrib_r x 1 {-1}
       || a + ({-1} # x) = 0 @a by <- prod_id_l x.

(** Proves that x + x -1 = 0. *)
Theorem prod_x_n1_inv_r
  :  forall x : E, sum_is_inv_r x (x # {-1}).
Proof
  fun x
    => prod_0_r x
       || x # a = 0          @a by E_n1_inv_r
       || a = 0              @a by <- prod_sum_distrib_l x 1 {-1}
       || a + (x # {-1}) = 0 @a by <- prod_id_r x.

(** Proves that -1 x is the additive inverse of x. *)
Theorem prod_n1_x_inv
  :  forall x : E, sum_is_inv x ({-1} # x).
Proof fun x => conj (prod_n1_x_inv_l x) (prod_n1_x_inv_r x).

(** Proves that x -1 is the additive inverse of x. *)
Theorem prod_x_n1_inv
  :  forall x : E, sum_is_inv x (x # {-1}).
Proof fun x => conj (prod_x_n1_inv_l x) (prod_x_n1_inv_r x).

(**
  Proves that multiplying by -1 is equivalent
  to negation.
*)
Theorem prod_n1_neg
  :  prod {-1} = {-}.
Proof
  functional_extensionality
    (prod {-1}) {-}
    (fun x
      => sum_inv_uniq x (- x) ({-1} # x)
           (sum_neg_def x)
           (prod_n1_x_inv x)).

(**
  Accepts one element, x, and proves that
  x -1 equals the additive negation of x.
*)
Theorem prod_x_n1_neg
  :  forall x : E, x # {-1} = - x.
Proof
  fun x
    => sum_inv_uniq x (- x) (x # {-1})
         (sum_neg_def x)
         (prod_x_n1_inv x).

(**
  Accepts one element, x, and proves that
  -1 x equals the additive negation of x.
*)
Theorem prod_n1_x_neg
  :  forall x : E, {-1} # x = - x.
Proof
  fun x
    => sum_inv_uniq x (- x) ({-1} # x)
         (sum_neg_def x)
         (prod_n1_x_inv x).

(** Proves that -1 x = x -1. *)
Theorem prod_n1_eq
  :  forall x : E, {-1} # x = x # {-1}.
Proof
  fun x
    => sum_inv_uniq x (x # {-1}) ({-1} # x)
         (prod_x_n1_inv x)
         (prod_n1_x_inv x).

(** Proves that the additive negation of 1 equals -1. *)
Theorem neg_1
  :  {-} 1 = {-1}.
Proof
  eq_refl ({-} 1)
    || {-} 1 = a @a by prod_x_n1_neg 1
    || {-} 1 = a @a by <- prod_id_l {-1}.

(** Proves that the additive negation of -1 equals 1. *)
Theorem neg_n1
  :  {-} {-1} = 1.
Proof sum_neg_rev 1 {-1} neg_1.

(**
  Proves that -1 * -1 = 1.

  -1 * -1 = -1 * -1
  -1 * -1 = prod -1 -1
  -1 * -1 = - -1
  -1 * -1 = 1
*)
Theorem prod_n1_n1
  :  {-1} # {-1} = 1.
Proof
  eq_refl ({-1} # {-1})
    || {-1} # {-1} = a @a by <- prod_n1_x_neg {-1}
    || {-1} # {-1} = a @a by <- neg_n1.

(**
  Proves that -1 is its own multiplicative
  inverse.
*)
Theorem E_n1_inv
  :  prod_is_inv {-1} {-1}.
Proof conj prod_n1_n1 prod_n1_n1.

End Theorems.

End Ring.

Notation "0" := (Ring.E_0) : ring_scope.

Notation "1" := (Ring.E_1) : ring_scope.

Notation "x + y" := (Ring.sum x y) (at level 50, left associativity) : ring_scope.

Notation "{+}" := (Ring.sum) : ring_scope.

Notation "{-}" := (Ring.sum_neg _) : ring_scope.

Notation "- x" := (Ring.sum_neg _ x) : ring_scope.

Notation "x # y" := (Ring.prod x y) (at level 50, left associativity) : ring_scope.

Notation "{#}" := (Ring.prod) : ring_scope.