Parameter set : Type.
Parameter In : set -> set -> Prop.

Notation "x ∈ y" := (In x y) (at level 30).
Notation "x ∋ y" := (In y x) (at level 30).

Definition subset (A B: set) : Prop :=
forall x:set, x ∈ A -> x ∈ B.

Notation "x ⊆ y" := (subset x y) (at level 30).
Notation "x ⊇ y" := (subset y x) (at level 30).

Theorem subset_reflexive : forall (A : set),
A ⊆ A.
Proof.
intros. unfold subset. intros.
apply H.
Qed.

Theorem subset_transitive : forall (A B C : set),
A ⊆ B /\ B ⊆ C -> A ⊆ C.
Proof.
intros A B C. unfold subset. intros.
inversion H. apply H2. apply H1. apply H0.
Qed.

Parameter Φ : set.
Axiom Axiom_of_Existence :
forall x:set, not (x ∈ Φ).

Axiom Axiom_of_Extensionality :
forall (A B : set), (forall x:set, x ∈ A <-> x ∈ B) -> A = B.

Theorem subset_antisymmetric : forall (A B : set),
A ⊆ B /\ B ⊆ A -> A = B.
Proof.
intros. apply Axiom_of_Extensionality.
inversion H. unfold subset in H0. unfold subset in H1.
intros x. unfold iff. apply conj. apply H0. apply H1.
Qed.

Axiom Axiom_of_Regularity : forall A : set,
(exists B :set, B ∈ A) -> (exists B : set, B ∈ A /\ not (exists C : set, C ∈ A /\ C ∈ B)).

Axiom Axiom_of_Pairing : forall (A B : set),
exists C, A ∈ C /\ B ∈ C.

Axiom Axiom_of_Union : forall (A : set),
exists U, forall (x y: set), x ∈ y /\ y ∈ A -> x ∈ U.

Axiom Axiom_of_Powerset : forall (A : set),
exists B, forall (x : set), x ⊆ A -> x ∈ B.


Require Import ZArith PArith Lia.
Require Import ASN1FP.Types.ASN
        ASN1FP.Aux.Roundtrip ASN1FP.Aux.StructTactics ASN1FP.Aux.Aux
        ASN1FP.Aux.Tactics ASN1FP.Aux.Option ASN1FP.Aux.StrongInduction.

Require Import Flocq.Core.Zaux Flocq.IEEE754.Binary Flocq.Core.Defs.

Open Scope Z.

(*
 *  eqivalence on floats of the same type, returning `true`
 *  for normal equality
 *  or for any two NaN values (NaN payloads not taken into account)
 *)
Definition float_eqb_nan_t {prec emax : Z} (x y : binary_float prec emax) : bool :=
  match Bcompare prec emax x y with
  | Some Eq => true
  | None => true
  | _ => false
  end.

Definition binary_bounded_sumbool (prec emax : Z) (m : positive) (e : Z) :=
  Sumbool.sumbool_of_bool (Binary.bounded prec emax m e).

Section Base2.

  Variable prec emax : Z.
  Hypothesis prec_gt_1 : prec > 1.
  Hypothesis Hmax : (prec < emax)%Z.

  (* only radix = 2 is considered for both formats in this section
   * scaling factor is, therefore, not required in BER
   * TODO: for arbitrary radix/scaling combinations, refer to another section
   *)
  Let r := radix2.
  Let scl := 0.
  (* can a given (m,e) pair be represented in IEEE/BER exactly *)
  Let valid_IEEE := bounded prec emax.
  Let valid_BER := valid_BER r scl.

  (* aux: apply variables *)
  Let IEEE_float := binary_float prec emax.
  Let valid_IEEE_sumbool := binary_bounded_sumbool prec emax.
  Let BER_finite_b2 := BER_finite r scl.
  Let valid_BER_sumbool := valid_BER_sumbool r scl.

  (* 1 can always be the payload of a NaN *)
  Lemma def_NaN :
    nan_pl prec 1 = true.
  Proof.
    unfold nan_pl. simpl.
    apply Z.ltb_lt, Z.gt_lt, prec_gt_1.
  Qed.

  Lemma prec_gt_0 : Flocq.Core.FLX.Prec_gt_0 prec.
  Proof.
    unfold Flocq.Core.FLX.Prec_gt_0.
    apply (Z.lt_trans 0 1 prec).
    - (* 1 < 0 *)
      reflexivity.
    - (* 1 < prec *)
      apply Z.gt_lt.
      apply prec_gt_1.
  Qed.

  Section Def.

    (*
     * given a pair (m,e), return (mx, ex) such that
     *   m*2^e = mx*2^ex
     * and
     *   m is odd
     *)
    Definition normalize_BER_finite_nrec (m : positive) (e : Z) : (positive * Z) :=
      let t := N.log2 (((Pos.lxor m (m-1)) + 1) / 2) in
      (Pos.shiftr m t, e + (Z.of_N t)).

    Fixpoint normalize_BER_finite (m : positive) (e : Z) : positive * Z :=
      match m with
      | xO p => normalize_BER_finite p (e + 1)
      | _ => (m, e)
      end.

    (*
     * given all meaningful parts of a BER real, construct it, if possible
     * The content is normalized in accordance with [ 11.3.1 ] if possible
     *)
    Definition make_BER_finite (s : bool) (m : positive) (e : Z)
      : option BER_float :=
      let '(mx, ex) := normalize_BER_finite m e in
      match valid_BER_sumbool mx ex with
      | left V => Some (BER_finite_b2 s mx ex V)
      | right _ => None
      end.

    (* TODO: radix, scaling (determine `b` and `ff`) *)
    (*
     * exact conversion from IEEE to BER
     * no rounding is performed: if conversion is impossible without rounding
     * `None` is returned
     *)
    Definition BER_of_IEEE_exact (f : IEEE_float) : option BER_float :=
      match f with
      | B754_zero _ _ s => Some (BER_zero s)
      | B754_infinity _ _ s => Some (BER_infinity s)
      | B754_nan _ _ _ _ _ => Some (BER_nan)
      | B754_finite _ _ s m e _ => make_BER_finite s m e
      end.

    (*
     * turn any pair (m,e) into a pair (mx,ex), representable in
     * IEEE 745 if possible. No rounding is performed,
     * (m,e) remains unchanged if normalization is impossible without rounding
     *)
    Definition normalize_IEEE_finite : positive -> Z -> (positive * Z) :=
      shl_align_fexp prec emax.

    (* given all meaningful parts of an IEEE float, construct it, if possible *)
    Definition make_IEEE_finite (s : bool) (m : positive) (e : Z) : option IEEE_float :=
      let '(mx, ex) := normalize_IEEE_finite m e in
      match (valid_IEEE_sumbool mx ex) with
      | left V => Some (B754_finite _ _ s mx ex V)
      | right _ => None
      end.

    (*
     * exact conversion from BER to IEEE
     * radix2 with no scaling asssumed: if input does not match, 'None' returned
     * no rounding is performed: if conversion is impossible without rounding
     * `None` is returned
     *)
    Definition IEEE_of_BER_exact (f : BER_float) : option IEEE_float :=
      match f with
      | BER_zero s => Some (B754_zero _ _ s)
      | BER_infinity s => Some (B754_infinity _ _ s)
      | BER_nan => Some (B754_nan _ _ false 1 def_NaN)
      | BER_finite b f s m e _ =>
        if andb (b =? 2) (f =? 0) then
          make_IEEE_finite s m e
        else None
      end.

    (*
     *  given a triple (s,m,e) standing for s*m*2^e,
     *  return a corresponding binary_float,
     *  correctly rounded in accordance with the specified rounding mode
     *)
    Definition round_finite
               (Hmax : prec < emax) (rounding : mode)
               (s : bool) (m : positive) (e : Z) : IEEE_float :=
      binary_normalize
        prec emax prec_gt_0 Hmax
        rounding
        (cond_Zopp s (Zpos m)) e s.

    (*
     *  for any ASN.1 BER-encoded real number s*m*(b^e)
     *  return the number's representation in the target IEEE format
     *  rounded in accordnace with the provided rounding mode if necessary
     *
     *  NOTE:
     *  1) If initial BER encoding has radix /= 2 or scaling factor /= 0
     *     `None` is returned
     *  2) If the ASN encoding is a NaN,
     *     float's NaN payload is set to 1
     *)
    Definition IEEE_of_BER_rounded (Hmax : prec < emax)
               (rounding : mode) (r : BER_float) : option (IEEE_float) :=
      match r with
      | BER_zero s => Some (B754_zero _ _ s)
      | BER_infinity s => Some (B754_infinity _ _ s)
      | BER_nan => Some (B754_nan _ _ false 1 def_NaN)
      | BER_finite b f s m e x =>
        if andb (b =? 2) (f =? 0)
        then Some (round_finite Hmax rounding s m e)
        else None
      end.

    (*
     *  given a binary_float and a rounding mode
     *  convert it to target format, rounding if necessary
     *
     *  NaN payload is set to 1 uncoditionally
     *)
    Definition IEEE_of_IEEE_round_reset_nan (Hmax : prec < emax)
               (rounding : mode) (f : IEEE_float) : IEEE_float :=
      match f with
      | B754_nan _ _ _ _ _ => B754_nan _ _ false 1 def_NaN
      | B754_infinity _ _ s => B754_infinity _ _ s
      | B754_zero _ _ s => B754_zero _ _ s
      | B754_finite _ _ s m e _ => round_finite Hmax rounding s m e
      end.

  End Def.

  Section Proof.

    Definition R_of_float (m : positive) (e : Z) :=
      F2R (Float radix2 (Zpos m) e).

    Lemma R_of_valid_IEEE_inj {m1 m2 : positive} {e1 e2 : Z} :
      valid_IEEE m1 e1 = true -> valid_IEEE m2 e2 = true ->
      R_of_float m1 e1 = R_of_float m2 e2 ->
      (m1, e1) = (m2,e2).
    Proof.
      intros V1 V2 Req.
      remember (B754_finite prec emax false m1 e1 V1) as f1.
      remember (B754_finite prec emax false m2 e2 V2) as f2.
      assert (fin_f1 : is_finite_strict prec emax f1 = true) by (subst; auto).
      assert (fin_f2 : is_finite_strict prec emax f2 = true) by (subst; auto).
      generalize (B2R_inj prec emax f1 f2 fin_f1 fin_f2); intros.
      unfold B2R in H.
      rewrite Heqf1, Heqf2 in H.
      apply H in Req.
      inversion Req.
      auto.
    Qed.

    Lemma normalize_IEEE_eq (m : positive) (e : Z) :
      R_of_float m e =
      uncurry R_of_float (normalize_IEEE_finite m e).
    Proof.
      unfold R_of_float, normalize_IEEE_finite, uncurry.
      break_let.
      generalize (shl_align_fexp_correct prec emax m e).
      intros H; rewrite Heqp in H; apply proj1 in H.
      apply H.
    Qed.

    Definition Podd (p : positive) : Prop :=
      match p with
      | xO _ => False
      | _ => True
      end.

    Lemma p_lt_2p (p : positive) :
      (p < p~0)%positive.
    Proof. rewrite <- (Pos.add_diag p); lia. Qed.

    Lemma normalize_BER_odd (m : positive) (e : Z) :
      let '(mx, ex) := normalize_BER_finite m e in
      Podd mx.
    Proof.
      generalize e.
      induction m using positive_lt_ind.
      destruct m; try reflexivity.
      simpl.
      assert (H1 : (m < m~0)%positive) by apply p_lt_2p.
      intros.
      apply H with (y := m) (e := e0 + 1) in H1.
      apply H1.
    Qed.

    Lemma normalize_BER_eq (m : positive) :
      forall (e : Z),
      let '(mx, ex) := normalize_BER_finite m e in
      (mx, ex) = (m, e)
      \/
      exists (d : positive),
        m = (mx * 2^d)%positive /\ e = ex - (Zpos d).
    Proof.
      clear Hmax valid_IEEE IEEE_float valid_IEEE_sumbool prec emax prec_gt_1 Hmax.
      clear r valid_BER_sumbool BER_finite_b2 valid_BER.

      induction m using positive_lt_ind.
      intros.
      destruct (normalize_BER_finite m e) as (mx,ex) eqn:NB.
      destruct m; try (simpl in NB; tuple_inversion; left; trivial).
      rewrite <- Pos.add_diag.

      simpl in NB.
      assert (H1 : (m < m~0)%positive) by apply p_lt_2p.
      apply H with (y := m) (e := e + 1) in H1.
      rewrite NB in H1.
      destruct H1.
      - tuple_inversion.
        right.
        exists (1%positive).
        replace (2^1)%positive with 2%positive by trivial.
        lia.
      - right.
        destruct H0 as [d H0].
        exists (d + 1)%positive.
        replace (2^(d + 1))%positive with (2 * (2^d))%positive
          by (rewrite Positive_as_OT.add_1_r, Positive_as_DT.pow_succ_r; trivial).
        lia.
    Qed.

    Lemma normalize_BER_spec (m mx : positive) (e ex : Z) :
      (mx, ex) = normalize_BER_finite m e ->
      Podd mx
      /\
      ((mx, ex) = (m, e)
      \/
      exists (d : positive),
        m = (mx * 2^d)%positive /\ e = ex - (Zpos d)).
    Proof.
      intros NB.
      split.
      - generalize (normalize_BER_odd m e); intros.
        rewrite <- NB in H.
        apply H.
      - generalize (normalize_BER_eq m e); intros.
        rewrite <- NB in H.
        apply H.
    Qed.

    Lemma normalize_BER_Req (m : positive) (e : Z) :
      uncurry R_of_float (normalize_BER_finite m e) =
      R_of_float m e.
    Proof.
      unfold R_of_float, uncurry.
      break_let.
      rename p into mx, z into ex, Heqp into H.
      symmetry in H.
      apply normalize_BER_spec in H.
      destruct H as [H0 [H1|H2]].
      -
        tuple_inversion.
        reflexivity.
      -
        destruct H2 as [d [H2 H3]].
        subst.
        rewrite Pos2Z.inj_mul.
        rewrite Pos2Z.inj_pow.
        remember (ex - Z.pos d) as ex'.
        replace (Z.pos d) with (ex - ex') by lia.
        apply (Float_prop.F2R_change_exp radix2).
        lia.
    Qed.

    Let normalize_roundtrip (m : positive) (e : Z) :=
      uncurry normalize_IEEE_finite
              (normalize_BER_finite m e).

    Lemma normalize_roundtrip_eq (m : positive) (e : Z) :
      uncurry R_of_float (normalize_roundtrip m e) =
      R_of_float m e.
    Proof.
      unfold normalize_roundtrip.
      rewrite <- normalize_BER_Req.
      destruct (normalize_BER_finite m e) as (mx,ex) eqn:NB.
      assert (uncurry normalize_IEEE_finite (mx, ex) = normalize_IEEE_finite mx ex)
        by (unfold uncurry; reflexivity).
      rewrite H.
      rewrite <- normalize_IEEE_eq.
      auto.
    Qed.

    Lemma digits2_size (p : positive) :
      Digits.digits2_pos p = Pos.size p.
    Proof.
      induction p; simpl; try rewrite IHp; reflexivity.
    Qed.

    Lemma normalize_roundtrip_valid (m : positive) (e : Z) :
      valid_IEEE m e = true ->
      uncurry valid_IEEE
              (normalize_roundtrip m e) = true.
    Proof.
      (* unfold everything, clean up *)
      unfold normalize_roundtrip.
      destruct (normalize_BER_finite m e) as (mx, ex) eqn:NB.
      destruct (uncurry normalize_IEEE_finite (mx, ex)) as (m', e') eqn:NI.
      unfold uncurry in *.
      unfold normalize_IEEE_finite, valid_IEEE, shl_align_fexp, shl_align,
      bounded, canonical_mantissa, uncurry, FLT.FLT_exp in *.
      clear r valid_IEEE valid_BER IEEE_float valid_IEEE_sumbool
            BER_finite_b2 valid_BER_sumbool normalize_roundtrip.

      (* remove bool *)
      intros H.
      apply andb_prop in H.
      destruct H as [H1 H2].
      debool.

      symmetry in NB. apply normalize_BER_spec in NB.
      destruct NB as [H3 H4].

      split_andb_goal; debool;
        rewrite digits2_size, Psize_log_inf, <- Zlog2_log_inf in *.
      -
        destruct H4.
        tuple_inversion.
        break_match_hyp; try (tuple_inversion; apply H1).
        + rewrite H1 in Heqz. rewrite Z.sub_diag in Heqz. inversion Heqz.
        + destruct H as [d [H0 H5]].
          break_match_hyp.
          * tuple_inversion; lia.
          * tuple_inversion.
            exfalso. (* Heqz vs goal *)
            unfold Z.max in *.
            repeat break_match_hyp; simpl; debool; try lia;
              rewrite Pos2Z.inj_mul, Pos2Z.inj_pow, Z.log2_mul_pow2 in *; lia.
          *
            subst.
            remember (shift_pos p mx) as pm.
            remember (Z.max (Z.succ (Z.log2 (Z.pos mx)) + ex - prec) (3 - emax - prec)) as pe.
            inversion NI. clear NI.
            subst pe pm.
            apply Pos2Z.inj_iff in H0.
            rewrite shift_pos_correct in H0.
            rewrite Pos2Z.inj_mul, Pos2Z.inj_pow, Z.log2_mul_pow2 in *; try lia.
            rewrite Z.pow_pos_fold in H0.
            subst.
            rewrite <- H0. clear m' H0.
            rewrite Z.mul_comm.
            rewrite Z.log2_mul_pow2; lia.
      -
        destruct H4.
        + tuple_inversion.
          break_match_hyp.
          * tuple_inversion.
            apply H2.
          * tuple_inversion.
            apply H2.
          * lia.
        + destruct H as [d [H4 H5]].
          break_match_hyp.
          * tuple_inversion.
            rewrite Pos2Z.inj_mul, Pos2Z.inj_pow, Z.log2_mul_pow2 in *; lia.
          * tuple_inversion.
            rewrite Pos2Z.inj_mul, Pos2Z.inj_pow, Z.log2_mul_pow2 in *; lia.
          *
            subst.
            remember (shift_pos p mx) as pm.
            remember (Z.max (Z.succ (Z.log2 (Z.pos mx)) + ex - prec) (3 - emax - prec)) as pe.
            inversion NI. clear NI.
            subst pe pm.
            apply Pos2Z.inj_iff in H0.
            rewrite shift_pos_correct in H0.
            rewrite Pos2Z.inj_mul, Pos2Z.inj_pow, Z.log2_mul_pow2 in *; lia.
    Qed.

    Theorem arithmetic_roundtrip (m : positive) (e : Z) :
      valid_IEEE m e = true ->
      normalize_roundtrip m e = (m, e).
    Proof.
      intros H.
      copy_apply normalize_roundtrip_valid H.
      unfold normalize_roundtrip, uncurry in *.
      destruct normalize_BER_finite as (mx,ex) eqn:NB.
      destruct normalize_IEEE_finite as (m',e') eqn:NI.
      apply R_of_valid_IEEE_inj.
      apply H0.
      apply H.
      assert (R_of_float m' e' = uncurry R_of_float (normalize_roundtrip m e)) by
        (unfold uncurry, normalize_roundtrip; rewrite NB, NI; reflexivity).
      rewrite H1.
      apply normalize_roundtrip_eq.
    Qed.

    Ltac inv_make_BER_finite :=
      match goal with
      | [ H : make_BER_finite _ _ _ = Some _ |- _ ] =>
        unfold make_BER_finite in H;
        destruct normalize_BER_finite;
        destruct valid_BER_sumbool;
        inversion H
    end.

    Ltac bcompare_nrefl :=
      match goal with
      | [ H: Bcompare _ _ _ _ = _ |- _] =>
        assert (H1 := H); rewrite -> Bcompare_swap in H1; rewrite -> H in H1; inversion H1
      end.

    Theorem main_roundtrip (scaled : bool) (f : IEEE_float):
      roundtrip_option
        IEEE_float BER_float IEEE_float
        (BER_of_IEEE_exact)
        IEEE_of_BER_exact
        (float_eqb_nan_t)
        f.
    Proof.
      intros FPT.
      unfold bool_het_inverse'; simpl.
      break_match.
      - (* forward pass successful *)
        clear FPT.
        break_match.
        + (* backward pass successful *)
          destruct f; destruct b; simpl in *; repeat try some_inv; try auto.
          (* structural errors *)
          * unfold float_eqb_nan_t, Bcompare.
            repeat break_match; (repeat try some_inv);
              try compare_nrefl; try reflexivity; try inversion Heqc.
          * inv_make_BER_finite.
          * inv_make_BER_finite.
          * (* arithmetic_roundtrip comes in play *)
             destruct ((b =? 2) && (f =? 0))%bool; inversion Heqo0; clear H0.

            (* simplify forward conversions *)
            unfold make_BER_finite in *.
            destruct normalize_BER_finite eqn:NB.
            destruct valid_BER_sumbool; inversion Heqo.
            clear Heqo; subst.

            (* simplify backward conversions *)
            unfold make_IEEE_finite in *.
            destruct normalize_IEEE_finite eqn:NI.
            destruct valid_IEEE_sumbool; inversion Heqo0.
            clear Heqo0; subst.

            (* apply arithmetic roundtrip *)
            copy_apply (arithmetic_roundtrip m e) e0.
            unfold normalize_roundtrip in H.
            rewrite -> NB in H.
            simpl in H.
            rewrite -> NI in H.
            inversion H; subst.
            unfold float_eqb_nan_t, Bcompare.
            repeat break_match; (repeat try some_inv);
              try compare_nrefl; try reflexivity.

        + (* backward pass unsuccessful *)
          destruct f; simpl in Heqo; inversion Heqo; subst; inversion Heqo0.
          clear H0 H1; exfalso.
          unfold make_BER_finite in Heqo.
          destruct normalize_BER_finite eqn:NB, valid_BER_sumbool;
            inversion Heqo; clear Heqo.
          subst.
          unfold BER_finite_b2 in Heqo0.
          simpl in Heqo0.
          unfold make_IEEE_finite in Heqo0.
          destruct normalize_IEEE_finite eqn:NI.
          destruct valid_IEEE_sumbool; inversion Heqo0; clear Heqo0.
          copy_apply (arithmetic_roundtrip m e) e0.
          unfold normalize_roundtrip in H.
          rewrite -> NB in H.
          simpl in H.
          rewrite -> NI in H.
          inversion H; subst.
          rewrite e0 in e2; inversion e2.
      - (* forward pass unsuccessful *)
        inversion FPT.
    Qed.

  End Proof.

End Base2.


(* ******************************************************************************* *)
(** Unitality laws are inverses
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Modifications.Modification.

Local Open Scope cat.

Section LeftUnitality.
  Context {B₁ B₂ : bicat}.
  Variable (F : psfunctor B₁ B₂).

  Definition lunitor_linvunitor_pstrans_data
    : invertible_modification_data
        (comp_pstrans (lunitor_pstrans F) (linvunitor_pstrans F))
        (id_pstrans _).
  Proof.
    intro X.
    use make_invertible_2cell.
    - exact (lunitor _).
    - is_iso.
  Defined.

  Definition lunitor_linvunitor_pstrans_is_modification
    : is_modification lunitor_linvunitor_pstrans_data.
  Proof.
    intros X Y f ; cbn.
    rewrite <- lwhisker_vcomp.
    rewrite !vassocr.
    rewrite lunitor_lwhisker.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocl.
    rewrite lwhisker_vcomp.
    rewrite linvunitor_lunitor, lwhisker_id2, id2_right.
    rewrite vcomp_lunitor.
    rewrite runitor_lunitor_identity.
    apply idpath.
  Qed.

  Definition lunitor_linvunitor_pstrans
    : invertible_modification
        (comp_pstrans (lunitor_pstrans F) (linvunitor_pstrans F))
        (id_pstrans _).
  Proof.
    use make_invertible_modification.
    - exact lunitor_linvunitor_pstrans_data.
    - exact lunitor_linvunitor_pstrans_is_modification.
  Defined.

  Definition linvunitor_lunitor_pstrans_data
    : invertible_modification_data
        (comp_pstrans (linvunitor_pstrans F) (lunitor_pstrans F))
        (id_pstrans _).
  Proof.
    intro X.
    use make_invertible_2cell.
    - exact (lunitor _).
    - is_iso.
  Defined.

  Definition linvunitor_lunitor_pstrans_is_modification
    : is_modification linvunitor_lunitor_pstrans_data.
  Proof.
    intros X Y f ; cbn.
    rewrite <- lwhisker_vcomp.
    rewrite !vassocr.
    rewrite lunitor_lwhisker.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocl.
    rewrite lwhisker_vcomp.
    rewrite linvunitor_lunitor, lwhisker_id2, id2_right.
    rewrite vcomp_lunitor.
    rewrite runitor_lunitor_identity.
    apply idpath.
  Qed.

  Definition linvunitor_lunitor_pstrans
    : invertible_modification
        (comp_pstrans (linvunitor_pstrans F) (lunitor_pstrans F))
        (id_pstrans _).
  Proof.
    use make_invertible_modification.
    - exact linvunitor_lunitor_pstrans_data.
    - exact linvunitor_lunitor_pstrans_is_modification.
  Defined.
End LeftUnitality.

Section RightUnitality.
  Context {B₁ B₂ : bicat}.
  Variable (F : psfunctor B₁ B₂).

  Definition runitor_rinvunitor_pstrans_data
    : invertible_modification_data
        (comp_pstrans (runitor_pstrans F) (rinvunitor_pstrans F))
        (id_pstrans _).
  Proof.
    intro X.
    use make_invertible_2cell.
    - exact (lunitor _).
    - is_iso.
  Defined.

  Definition runitor_rinvunitor_pstrans_is_modification
    : is_modification runitor_rinvunitor_pstrans_data.
  Proof.
    intros X Y f ; cbn.
    rewrite <- lwhisker_vcomp.
    rewrite !vassocr.
    rewrite lunitor_lwhisker.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocl.
    rewrite lwhisker_vcomp.
    rewrite linvunitor_lunitor, lwhisker_id2, id2_right.
    rewrite vcomp_lunitor.
    rewrite runitor_lunitor_identity.
    apply idpath.
  Qed.

  Definition runitor_rinvunitor_pstrans
    : invertible_modification
        (comp_pstrans (runitor_pstrans F) (rinvunitor_pstrans F))
        (id_pstrans _).
  Proof.
    use make_invertible_modification.
    - exact runitor_rinvunitor_pstrans_data.
    - exact runitor_rinvunitor_pstrans_is_modification.
  Defined.

  Definition rinvunitor_runitor_pstrans_data
    : invertible_modification_data
        (comp_pstrans (rinvunitor_pstrans F) (runitor_pstrans F))
        (id_pstrans _).
  Proof.
    intro X.
    use make_invertible_2cell.
    - exact (lunitor _).
    - is_iso.
  Defined.

  Definition rinvunitor_runitor_pstrans_is_modification
    : is_modification rinvunitor_runitor_pstrans_data.
  Proof.
    intros X Y f ; cbn.
    rewrite <- lwhisker_vcomp.
    rewrite !vassocr.
    rewrite lunitor_lwhisker.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocl.
    rewrite lwhisker_vcomp.
    rewrite linvunitor_lunitor, lwhisker_id2, id2_right.
    rewrite vcomp_lunitor.
    rewrite runitor_lunitor_identity.
    apply idpath.
  Qed.

  Definition rinvunitor_runitor_pstrans
    : invertible_modification
        (comp_pstrans (rinvunitor_pstrans F) (runitor_pstrans F))
        (id_pstrans _).
  Proof.
    use make_invertible_modification.
    - exact rinvunitor_runitor_pstrans_data.
    - exact rinvunitor_runitor_pstrans_is_modification.
  Defined.
End RightUnitality.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export Bool Peano_dec Eqdep_dec.
Require Import Setoid.
Require Export ZArithRing Field.

(* We define our own field *)

Parameter F : Set.
Parameter F0 : F.
Parameter F1 : F.
Parameter Fplus : F -> F -> F.
Parameter Fmult : F -> F -> F.
Parameter Fopp : F -> F.
Parameter Finv : F -> F.

Definition Feq (x y : F) : bool := false.

Definition Fminus (r1 r2 : F) : F := Fplus r1 (Fopp r2).
Definition Fdiv (r1 r2 : F) : F := Fmult r1 (Finv r2).

(***************)
(* Notations  *)
(***************)

Delimit Scope F_scope with F.
Infix "+" := Fplus : F_scope.
Infix "-" := Fminus : F_scope.
Infix "*" := Fmult : F_scope.
Infix "/" := Fdiv : F_scope.
Notation "- x" := (Fopp x) : F_scope.

Notation "0" := F0 : F_scope.
Notation "1" := F1 : F_scope.
Notation "2" := (1 + 1)%F : F_scope.

Notation "/ x" := (Finv x) : F_scope.

(*Distfix 30 "/ _" Finv : F_scope V8only.*)
(* Notation "x <> y" := ~(eqT F x y) (at level 5) : F_scope. *)

Open Scope F_scope.

(***********)
(* Axioms *)
(***********)

(*********************************************************)
(*      Addition                                                          *)
(*********************************************************)

Axiom Fplus_sym : forall r1 r2 : F, r1 + r2 = r2 + r1.
Hint Resolve Fplus_sym: field_hints.

Axiom Fplus_assoc : forall r1 r2 r3 : F, r1 + r2 + r3 = r1 + (r2 + r3).
Hint Resolve Fplus_assoc: field_hints.

Axiom Fplus_Fopp_r : forall r : F, r + - r = 0.
Hint Resolve Fplus_Fopp_r: field_hints.

Axiom Fplus_Ol : forall r : F, 0 + r = r.
Hint Resolve Fplus_Ol: field_hints.

(***********************************************************)
(*       Multiplication                                    *)
(***********************************************************)

Axiom Fmult_sym : forall r1 r2 : F, r1 * r2 = r2 * r1.
Hint Resolve Fmult_sym: field_hints.

Axiom Fmult_assoc : forall r1 r2 r3 : F, r1 * r2 * r3 = r1 * (r2 * r3).
Hint Resolve Fmult_assoc: field_hints.

Axiom Finv_l : forall r : F, r <> 0 -> / r * r = 1.
Hint Resolve Finv_l: field_hints.

Axiom Fmult_1l : forall r : F, 1 * r = r.
Hint Resolve Fmult_1l: field_hints.

Axiom F1_neq_F0 : 1 <> 0.
Hint Resolve F1_neq_F0: field_hints.

(*********************************************************)
(*      Distributivity                                   *)
(*********************************************************)

Axiom
  Fmult_Fplus_distr : forall r1 r2 r3 : F, r1 * (r2 + r3) = r1 * r2 + r1 * r3.
Hint Resolve Fmult_Fplus_distr: field_hints.

Lemma Fmult_Fplus_distr_r : forall r2 r3 r1 : F, (r2 + r3) * r1 = r2 * r1 + r3 * r1.
Proof.
intros.
rewrite Fmult_sym.
rewrite (Fmult_sym r2 r1).
rewrite (Fmult_sym r3 r1).
apply Fmult_Fplus_distr.
Qed.

(*********************************************************)
(*      Instanciation of the new ring tactic             *)
(*********************************************************)

 Lemma FRth : ring_theory 0 1 Fplus Fmult Fminus Fopp (@eq F).
 Proof.
  constructor. exact Fplus_Ol. exact Fplus_sym.
  intros;symmetry;apply Fplus_assoc.
  exact Fmult_1l. exact Fmult_sym.
  intros;symmetry;apply Fmult_assoc.
  exact Fmult_Fplus_distr_r. trivial. exact Fplus_Fopp_r.
 Qed.

 Lemma Fth : field_theory 0 1 Fplus Fmult Fminus Fopp Fdiv Finv (@eq F).
Proof.
constructor.
 exact FRth.
 exact F1_neq_F0.
 reflexivity.
 exact Finv_l.
Qed.

Add Field Ff : Fth.

Ltac Fring := ring || ring_simplify.

(** The new ring tactic is efficient, here is an example
which is very slow with the legacy ring tactic *)

Goal forall a b:F, 2*2*2*2*2*2*a*b=2*2*2*2*2*2*a*b.
intros.
Fring.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.ZArith.Znumtheory.
Require Import Crypto.Util.ZUtil.Tactics.CompareToSgn.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Le.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.Hints.PullPush.
Require Import Crypto.Util.ZUtil.Hints.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.ZUtil.Pow.
Local Open Scope Z_scope.

Module Z.
  Lemma div_mul' : forall a b : Z, b <> 0 -> (b * a) / b = a.
  Proof. intros. rewrite Z.mul_comm. apply Z.div_mul; auto. Qed.
  Hint Rewrite div_mul' using zutil_arith : zsimplify.

  Local Ltac replace_to_const c :=
    repeat match goal with
           | [ H : ?x = ?x |- _ ] => clear H
           | [ H : ?x = c, H' : context[?x] |- _ ] => rewrite H in H'
           | [ H : c = ?x, H' : context[?x] |- _ ] => rewrite <- H in H'
           | [ H : ?x = c |- context[?x] ] => rewrite H
           | [ H : c = ?x |- context[?x] ] => rewrite <- H
           end.

  Lemma lt_div_0 n m : n / m < 0 <-> ((n < 0 < m \/ m < 0 < n) /\ 0 < -(n / m)).
  Proof.
    Z.compare_to_sgn; rewrite Z.sgn_opp; simpl.
    pose proof (Zdiv_sgn n m) as H.
    pose proof (Z.sgn_spec (n / m)) as H'.
    repeat first [ progress intuition auto
                 | progress simpl in *
                 | congruence
                 | lia
                 | progress replace_to_const (-1)
                 | progress replace_to_const 0
                 | progress replace_to_const 1
                 | match goal with
                   | [ x : Z |- _ ] => destruct x
                   end ].
  Qed.

  Lemma div_add' a b c : c <> 0 -> (a + c * b) / c = a / c + b.
  Proof. intro; rewrite <- Z.div_add, (Z.mul_comm c); try lia. Qed.
  Lemma div_add_l' a b c : b <> 0 -> (b * a + c) / b = a + c / b.
  Proof. intro; rewrite <- Z.div_add_l, (Z.mul_comm b); lia. Qed.
  Hint Rewrite Z.div_add' Z.div_add_l' using zutil_arith : push_Zdiv.
  Hint Rewrite <- Z.div_add' Z.div_add_l' using zutil_arith : pull_Zdiv.
  Hint Rewrite div_add_l' div_add' using zutil_arith : zsimplify.

  Lemma div_sub a b c : c <> 0 -> (a - b * c) / c = a / c - b.
  Proof. intros; rewrite <- !Z.add_opp_r, <- Z.div_add by lia; apply f_equal2; lia. Qed.

  Lemma div_sub' a b c : c <> 0 -> (a - c * b) / c = a / c - b.
  Proof. intro; rewrite <- div_sub, (Z.mul_comm c); try lia. Qed.

  Hint Rewrite div_sub div_sub' using zutil_arith : zsimplify.

  Lemma div_add_sub_l a b c d : b <> 0 -> (a * b + c - d) / b = a + (c - d) / b.
  Proof. rewrite <- Z.add_sub_assoc; apply Z.div_add_l. Qed.

  Lemma div_add_sub_l' a b c d : b <> 0 -> (b * a + c - d) / b = a + (c - d) / b.
  Proof. rewrite <- Z.add_sub_assoc; apply Z.div_add_l'. Qed.

  Lemma div_add_sub a b c d : c <> 0 -> (a + b * c - d) / c = (a - d) / c + b.
  Proof. rewrite (Z.add_comm _ (_ * _)), (Z.add_comm (_ / _)); apply Z.div_add_sub_l. Qed.

  Lemma div_add_sub' a b c d : c <> 0 -> (a + c * b - d) / c = (a - d) / c + b.
  Proof. rewrite (Z.add_comm _ (_ * _)), (Z.add_comm (_ / _)); apply Z.div_add_sub_l'. Qed.

  Hint Rewrite Z.div_add_sub Z.div_add_sub' Z.div_add_sub_l Z.div_add_sub_l' using zutil_arith : zsimplify.

  Lemma div_mul_skip a b k : 0 < b -> 0 < k -> a * b / k / b = a / k.
  Proof.
    intros; rewrite Z.div_div, (Z.mul_comm k), <- Z.div_div by lia.
    autorewrite with zsimplify. reflexivity.
  Qed.

  Lemma div_mul_skip' a b k : 0 < b -> 0 < k -> b * a / k / b = a / k.
  Proof.
    intros; rewrite Z.div_div, (Z.mul_comm k), <- Z.div_div by lia.
    autorewrite with zsimplify; reflexivity.
  Qed.

  Hint Rewrite Z.div_mul_skip Z.div_mul_skip' using zutil_arith : zsimplify.

  Lemma div_mul_skip_pow base e0 e1 x y : 0 < y -> 0 < base -> 0 <= e1 <= e0 -> x * base^e0 / y / base^e1 = x * base^(e0 - e1) / y.
  Proof.
    intros.
    assert (0 < base^e1) by auto with zarith.
    replace (base^e0) with (base^(e0 - e1) * base^e1) by (autorewrite with pull_Zpow zsimplify; reflexivity).
    rewrite !Z.mul_assoc.
    autorewrite with zsimplify; lia.
  Qed.
  Hint Rewrite div_mul_skip_pow using zutil_arith : zsimplify.

  Lemma div_mul_skip_pow' base e0 e1 x y : 0 < y -> 0 < base -> 0 <= e1 <= e0 -> base^e0 * x / y / base^e1 = base^(e0 - e1) * x / y.
  Proof.
    intros.
    rewrite (Z.mul_comm (base^e0) x), div_mul_skip_pow by lia.
    auto using f_equal2 with lia.
  Qed.
  Hint Rewrite div_mul_skip_pow' using zutil_arith : zsimplify.

  Lemma div_le_mono_nonneg a b c : 0 <= c -> a <= b -> a / c <= b / c.
  Proof.
    destruct (Z_zerop c).
    { subst; simpl; autorewrite with zsimplify; reflexivity. }
    { intros; apply Z.div_le_mono; lia. }
  Qed.
  Hint Resolve div_le_mono_nonneg : zarith.

  Lemma div_le_mono_pow_pos a b c e : a <= b -> a / Z.pos c ^ e <= b / Z.pos c ^ e.
  Proof. auto with zarith. Qed.

  Lemma div_nonneg a b : 0 <= a -> 0 <= b -> 0 <= a / b.
  Proof.
    destruct (Z_zerop b); subst; rewrite ?Zdiv_0_r; [ reflexivity | ].
    intros; apply Z.div_pos; lia.
  Qed.
  Hint Resolve div_nonneg : zarith.

  Lemma div_add_exact x y d : d <> 0 -> x mod d = 0 -> (x + y) / d = x / d + y / d.
  Proof.
    intros; rewrite (Z_div_exact_full_2 x d) at 1 by assumption.
    rewrite Z.div_add_l' by assumption; lia.
  Qed.
  Hint Rewrite div_add_exact using zutil_arith : zsimplify.

  Lemma Z_divide_div_mul_exact' a b c : b <> 0 -> (b | a) -> a * c / b = c * (a / b).
  Proof. intros. rewrite Z.mul_comm. auto using Z.divide_div_mul_exact. Qed.

  Lemma div_sub_mod_exact a b : b <> 0 -> a / b = (a - a mod b) / b.
  Proof.
    intro.
    rewrite (Z.div_mod a b) at 2 by lia.
    autorewrite with zsimplify.
    reflexivity.
  Qed.

  Lemma div_sub_mod_cond x y d
    : d <> 0
      -> (x - y) / d
         = x / d + ((x mod d - y) / d).
  Proof. clear.
         intro.
         replace (x - y) with ((x - x mod d) + (x mod d - y)) by lia.
         rewrite Z.div_add_exact by (autorewrite with pull_Zmod zsimplify; auto).
         rewrite <- Z.div_sub_mod_exact by lia; lia.
  Qed.
  Hint Resolve div_sub_mod_cond : zarith.

  Lemma div_add_mod_cond_l : forall x y d, d <> 0 -> (x + y) / d = (x mod d + y) / d + x / d.
  Proof.
    intros. replace (x + y) with ((x - x mod d) + (x mod d + y)) by lia.
    rewrite Z.div_add_exact by (autorewrite with pull_Zmod zsimplify; auto).
    rewrite <- Z.div_sub_mod_exact by lia; lia.
  Qed.

  Lemma div_add_mod_cond_r : forall x y d, d <> 0 -> (x + y) / d = (x + y mod d) / d + y / d.
  Proof.
    intros. rewrite Z.add_comm, div_add_mod_cond_l by auto. repeat (f_equal; try ring).
  Qed.

  Lemma div_le_zero x y : 0 < y -> x / y <= 0 -> x < y.
  Proof.
    clear. intros.
    apply Z.nle_gt; intro.
    pose proof (Z.div_str_pos x y ltac:(lia)). lia.
  Qed.

  Lemma div_between_full n a b :
    0 < b -> n * b <= a < (1 + n) * b ->
    a / b = n.
  Proof.
    intros.
    pose proof (Z.div_le_lower_bound a b n ltac:(lia) ltac:(lia)).
    pose proof (Z.div_lt_upper_bound a b (n+1) ltac:(lia) ltac:(lia)).
    lia.
  Qed.

  Lemma mod_small_n_neg n a b : n < 0 -> 0 < b -> n * b <= a < (1 + n) * b ->
                                a mod b = a - n * b.
  Proof.
    intros. rewrite Z.mod_eq, div_between_full with (n:=n) by lia. ring.
  Qed.

  Lemma div_div_comm : forall x y z,  0 < y -> 0 < z -> x / y / z = x / z / y.
  Proof.
    intros; rewrite !Z.div_div by lia.
    f_equal; ring.
  Qed.

  Lemma div_lt_upper_bound' a b q : 0 < b -> a < q * b -> a / b < q.
  Proof. intros; apply Z.div_lt_upper_bound; nia. Qed.
  Hint Resolve div_lt_upper_bound' : zarith.

  Lemma div_cross_le_abs a b c' d : c' <> 0 -> d <> 0 -> a * Z.sgn c' * Z.abs d <= b * Z.sgn d * Z.abs c' -> a / c' <= b / d.
  Proof.
    clear.
    destruct c', d; cbn [Z.abs Z.sgn];
      rewrite ?Zdiv_0_r, ?Z.mul_0_r, ?Z.mul_0_l, ?Z.mul_1_l, ?Z.mul_1_r;
      try lia; intros ?? H;
        Z.div_mod_to_quot_rem_in_goal;
        subst.
    all: repeat match goal with
                | [ H : context[_ * -1] |- _ ] => rewrite (Z.mul_add_distr_r _ _ (-1)), <- ?(Z.mul_comm (-1)), ?Z.mul_assoc in H
                | [ H : context[-1 * _] |- _ ] => rewrite (Z.mul_add_distr_l (-1)), <- ?(Z.mul_comm (-1)), ?Z.mul_assoc in H
                | [ H : context[-1 * Z.neg ?x] |- _ ] => rewrite (Z.mul_comm (-1) (Z.neg x)), <- Z.opp_eq_mul_m1 in H
                | [ H : context[-1 * ?x] |- _ ] => rewrite (Z.mul_comm (-1) x), <- Z.opp_eq_mul_m1 in H
                | [ H : context[-Z.neg _] |- _ ] => cbn [Z.opp] in H
                end.
    all:lazymatch goal with
        | [ H : (Z.pos ?p * ?q + ?r) * Z.pos ?p' <= (Z.pos ?p' * ?q' + ?r') * Z.pos ?p |- _ ]
          => let H' := fresh in
             assert (H' : q <= q' + (r' * Z.pos p - r * Z.pos p') / (Z.pos p * Z.pos p')) by (Z.div_mod_to_quot_rem_in_goal; nia);
               revert H'
        end.
    all:Z.div_mod_to_quot_rem_in_goal; nia.
  Qed.

  Lemma div_positive_gt_0 : forall a b, a > 0 -> b > 0 -> a mod b = 0 ->
    a / b > 0.
  Proof.
    intros; rewrite Z.gt_lt_iff.
    apply Z.div_str_pos.
    split; intuition auto with lia.
    apply Z.divide_pos_le; try (apply Zmod_divide); lia.
  Qed.

  Lemma div_opp_l_complete a b (Hb : b <> 0) : -a/b = -(a/b) - (if Z_zerop (a mod b) then 0 else 1).
  Proof.
    destruct (Z_zerop (a mod b)); autorewrite with zsimplify push_Zopp; reflexivity.
  Qed.

  Lemma div_opp_l_complete' a b (Hb : b <> 0) : -(a/b) = -a/b + (if Z_zerop (a mod b) then 0 else 1).
  Proof.
    destruct (Z_zerop (a mod b)); autorewrite with zsimplify pull_Zopp; lia.
  Qed.

  Hint Rewrite Z.div_opp_l_complete using zutil_arith : pull_Zopp.
  Hint Rewrite Z.div_opp_l_complete' using zutil_arith : push_Zopp.

  Lemma div_opp a : a <> 0 -> -a / a = -1.
  Proof.
    intros; autorewrite with pull_Zopp zsimplify; lia.
  Qed.

  Hint Rewrite Z.div_opp using zutil_arith : zsimplify.

  Lemma div_sub_1_0 x : x > 0 -> (x - 1) / x = 0.
  Proof. auto with zarith lia. Qed.

  Hint Rewrite div_sub_1_0 using zutil_arith : zsimplify.

  Lemma div_same' a b : b <> 0 -> a = b -> a / b = 1.
  Proof.
    intros; subst; auto with zarith.
  Qed.
  Hint Resolve div_same' : zarith.

  Lemma div_opp_r a b : a / (-b) = ((-a) / b).
  Proof. Z.div_mod_to_quot_rem; nia. Qed.
  Hint Resolve div_opp_r : zarith.

  Lemma div_floor : forall a b c, 0 < b -> a < b * (Z.succ c) -> a / b <= c.
  Proof.
    intros.
    apply Z.lt_succ_r.
    apply Z.div_lt_upper_bound; try lia.
  Qed.

  Lemma mul_div_le x y z
        (Hx : 0 <= x) (Hy : 0 <= y) (Hz : 0 < z)
        (Hyz : y <= z)
    : x * y / z <= x.
  Proof.
    transitivity (x * z / z); [ | rewrite Z.div_mul by lia; lia ].
    apply Z_div_le; nia.
  Qed.
  Hint Resolve mul_div_le : zarith.

  Lemma div_mul_diff_exact a b c
        (Ha : 0 <= a) (Hb : 0 < b) (Hc : 0 <= c)
    : c * a / b = c * (a / b) + (c * (a mod b)) / b.
  Proof.
    rewrite (Z_div_mod_eq a b) at 1 by lia.
    rewrite Z.mul_add_distr_l.
    replace (c * (b * (a / b))) with ((c * (a / b)) * b) by lia.
    rewrite Z.div_add_l by lia.
    lia.
  Qed.

  Lemma div_mul_diff_exact' a b c
        (Ha : 0 <= a) (Hb : 0 < b) (Hc : 0 <= c)
    : c * (a / b) = c * a / b - (c * (a mod b)) / b.
  Proof.
    rewrite div_mul_diff_exact by assumption; lia.
  Qed.

  Lemma div_mul_diff_exact'' a b c
        (Ha : 0 <= a) (Hb : 0 < b) (Hc : 0 <= c)
    : a * c / b = (a / b) * c + (c * (a mod b)) / b.
  Proof.
    rewrite (Z.mul_comm a c), div_mul_diff_exact by lia; lia.
  Qed.

  Lemma div_mul_diff_exact''' a b c
        (Ha : 0 <= a) (Hb : 0 < b) (Hc : 0 <= c)
    : (a / b) * c = a * c / b - (c * (a mod b)) / b.
  Proof.
    rewrite (Z.mul_comm a c), div_mul_diff_exact by lia; lia.
  Qed.

  Lemma div_mul_diff a b c
        (Ha : 0 <= a) (Hb : 0 < b) (Hc : 0 <= c)
    : c * a / b - c * (a / b) <= c.
  Proof.
    rewrite div_mul_diff_exact by assumption.
    ring_simplify; auto with zarith.
  Qed.

  Lemma div_mul_le_le a b c
    :  0 <= a -> 0 < b -> 0 <= c -> c * (a / b) <= c * a / b <= c * (a / b) + c.
  Proof.
    pose proof (Z.div_mul_diff a b c); split; try apply Z.div_mul_le; lia.
  Qed.

  Lemma div_mul_le_le_offset a b c
    : 0 <= a -> 0 < b -> 0 <= c -> c * a / b - c <= c * (a / b).
  Proof.
    pose proof (Z.div_mul_le_le a b c); lia.
  Qed.
  Hint Resolve div_mul_le_le_offset : zarith.

  Lemma div_x_y_x x y : 0 < x -> 0 < y -> x / y / x = 1 / y.
  Proof.
    intros; rewrite Z.div_div, (Z.mul_comm y x), <- Z.div_div, Z.div_same by lia.
    reflexivity.
  Qed.
  Hint Rewrite div_x_y_x using zutil_arith : zsimplify.

  Lemma sub_pos_bound_div a b X : 0 <= a < X -> 0 <= b < X -> -1 <= (a - b) / X <= 0.
  Proof.
    intros H0 H1; pose proof (Z.sub_pos_bound a b X H0 H1).
    assert (Hn : -X <= a - b) by lia.
    assert (Hp : a - b <= X - 1) by lia.
    split; etransitivity; [ | apply Z_div_le, Hn; lia | apply Z_div_le, Hp; lia | ];
      instantiate; autorewrite with zsimplify; try reflexivity.
  Qed.

  Hint Resolve (fun a b X H0 H1 => proj1 (Z.sub_pos_bound_div a b X H0 H1))
       (fun a b X H0 H1 => proj1 (Z.sub_pos_bound_div a b X H0 H1)) : zarith.

  Lemma sub_pos_bound_div_eq a b X : 0 <= a < X -> 0 <= b < X -> (a - b) / X = if a <? b then -1 else 0.
  Proof.
    intros H0 H1; pose proof (Z.sub_pos_bound_div a b X H0 H1).
    destruct (a <? b) eqn:?; Z.ltb_to_lt.
    { cut ((a - b) / X <> 0); [ lia | ].
      autorewrite with zstrip_div; auto with zarith lia. }
    { autorewrite with zstrip_div; auto with zarith lia. }
  Qed.

  Lemma add_opp_pos_bound_div_eq a b X : 0 <= a < X -> 0 <= b < X -> (-b + a) / X = if a <? b then -1 else 0.
  Proof.
    rewrite !(Z.add_comm (-_)), !Z.add_opp_r.
    apply Z.sub_pos_bound_div_eq.
  Qed.

  Hint Rewrite Z.sub_pos_bound_div_eq Z.add_opp_pos_bound_div_eq using zutil_arith : zstrip_div.

  Lemma div_small_sym a b : 0 <= a < b -> 0 = a / b.
  Proof. intros; symmetry; apply Z.div_small; assumption. Qed.
  Hint Resolve div_small_sym : zarith.

  Lemma mod_eq_le_div_1 a b : 0 < a <= b -> a mod b = 0 -> a / b = 1.
  Proof. intros; Z.div_mod_to_quot_rem; nia. Qed.
  Hint Resolve mod_eq_le_div_1 : zarith.
  Hint Rewrite mod_eq_le_div_1 using zutil_arith : zsimplify.

  Lemma div_small_neg x y : 0 < -x <= y -> x / y = -1.
  Proof. intros; Z.div_mod_to_quot_rem; nia. Qed.
  Hint Rewrite div_small_neg using zutil_arith : zsimplify.

  Lemma div_sub_small x y z : 0 <= x < z -> 0 <= y <= z -> (x - y) / z = if x <? y then -1 else 0.
  Proof.
    pose proof (Zlt_cases x y).
    (destruct (x <? y) eqn:?);
      intros; autorewrite with zsimplify; try lia.
  Qed.
  Hint Rewrite div_sub_small using zutil_arith : zsimplify.

  Lemma mul_div_lt_by_le x y z b : 0 <= y < z -> 0 <= x < b -> x * y / z < b.
  Proof.
    intros [? ?] [? ?]; eapply Z.le_lt_trans; [ | eassumption ].
    auto with zarith.
  Qed.
  Hint Resolve mul_div_lt_by_le : zarith.

  Definition mul_div_le'
    := fun x y z w p H0 H1 H2 H3 => @Z.le_trans _ _ w (@Z.mul_div_le x y z H0 H1 H2 H3) p.
  Hint Resolve mul_div_le' : zarith.
  Lemma mul_div_le'' x y z w : y <= w -> 0 <= x -> 0 <= y -> 0 < z -> x <= z -> x * y / z <= w.
  Proof.
    rewrite (Z.mul_comm x y); intros; apply mul_div_le'; assumption.
  Qed.
  Hint Resolve mul_div_le'' : zarith.

  Lemma div_between n a b : 0 <= n -> b <> 0 -> n * b <= a < (1 + n) * b -> a / b = n.
  Proof. intros; Z.div_mod_to_quot_rem_in_goal; nia. Qed.
  Hint Rewrite div_between using zutil_arith : zsimplify.

  Lemma div_between_1 a b : b <> 0 -> b <= a < 2 * b -> a / b = 1.
  Proof. intros; rewrite (div_between 1) by lia; reflexivity. Qed.
  Hint Rewrite div_between_1 using zutil_arith : zsimplify.

  Lemma div_between_if n a b : 0 <= n -> b <> 0 -> n * b <= a < (2 + n) * b -> (a / b = if (1 + n) * b <=? a then 1 + n else n)%Z.
  Proof.
    intros.
    break_match; Z.ltb_to_lt;
      apply div_between; lia.
  Qed.

  Lemma div_between_0_if a b : b <> 0 -> 0 <= a < 2 * b -> a / b = if b <=? a then 1 else 0.
  Proof. intros; rewrite (div_between_if 0) by lia; autorewrite with zsimplify_const; reflexivity. Qed.

  Lemma div2_split a b c (Hc : 0 < c) :
  (a + 2 ^ c * b) / 2 = a / 2 + 2 ^ (c - 1) * (b mod 2) + 2 ^ c * (b / 2).
  Proof.
    replace (2^c * b) with (2 * (2^(c - 1) * b)).
    rewrite Div.Z.div_add',  <- (Z.div2_div b) by lia.
    destruct (Z.odd b) eqn:E; rewrite Zmod_odd, E;
      rewrite (Zdiv2_odd_eqn b) at 1; rewrite E; ring_simplify;
        rewrite Pow.Z.pow_mul_base, Z.sub_simpl_r; lia.
    rewrite Z.mul_assoc, Pow.Z.pow_mul_base, Z.sub_simpl_r; lia. Qed.
End Z.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import perm zmodp matrix.
Require Import Reals Fourier.
Require Import Reals_ext ssr_ext ssralg_ext Rssr log2 Rbigop proba entropy.
Require Import binary_entropy_function channel hamming channel_code.

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

(** * Definition of erasure channel *)

Local Open Scope channel_scope.

Module EC.

Section EC_sect.

Variable A : finType.
Variable p : R.
Hypothesis p_01 : 0 <= p <= 1.

(** Definition of n-ary Erasure Channel (EC) *)

Definition f (a : A) := fun b =>
  if b is Some a' then
    if a == a' then 1 - p else 0
  else p.

Lemma f0 a b : 0 <= f a b.
Proof. rewrite /f.
  case: b => [a'|]; last by case: p_01.
  case: ifP => _. case: p_01 => ? ?; fourier.
  fourier.
Qed.

Lemma f1 (a : A) : \rsum_(a' : {:option A}) f a a' = 1.
Proof.
rewrite (bigD1 None) //=.
rewrite (bigD1 (Some a)) //=.
rewrite eqxx /=.
rewrite -Req_0_rmul. field.
rewrite /f; case=> [a'| //].
by case: ifP => /= [/eqP -> | //]; rewrite eqxx.
Qed.

Definition c : `Ch_1(A, [finType of option A]) :=
  fun a => makeDist (f0 a) (f1 a).

End EC_sect.

Section EC_prob.

Variable X : finType.
Hypothesis card_X : #|X| = 2%nat.
Variable P : dist X.
Variable erp : R.
Hypothesis erp_01 : 0 <= erp <= 1.

Let BEC := @EC.c X erp erp_01.
Local Notation X0 := (Two_set.val0 card_X).
Local Notation X1 := (Two_set.val1 card_X).
Let q := P(X0).
Local Notation W := (EC.f erp).
Local Notation P'W := (JointDist.f P BEC).
Local Notation PW := (OutDist.f P BEC).

Lemma EC_non_flip (a : X)(i : option_finType X):
(i != None) && (i != Some a) -> 0 = EC.f erp a i.
Proof.
case i => a' //=.
case: ifP => /eqP; last by [].
move=> ->.
by rewrite eqxx.
Qed.

End EC_prob.

End EC.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Basic facts about Prop as a type *)

(** An intuitionistic theorem from topos theory [[LambekScott]]

References:

[[LambekScott]] Jim Lambek, Phil J. Scott, Introduction to higher
order categorical logic, Cambridge Studies in Advanced Mathematics
(Book 7), 1988.

*)

Theorem injection_is_involution_in_Prop
  (f : Prop -> Prop)
  (inj : forall A B, (f A <-> f B) -> (A <-> B))
  (ext : forall A B, A <-> B -> f A <-> f B)
  : forall A, f (f A) <-> A.
Proof.
intros.
enough (f (f (f A)) <-> f A) by (apply inj; assumption).
split; intro H.
- now_show (f A).
  enough (f A <-> True) by firstorder.
  enough (f (f A) <-> f True) by (apply inj; assumption).
  split; intro H'.
  + now_show (f True).
    enough (f (f (f A)) <-> f True) by firstorder.
    apply ext; firstorder.
  + now_show (f (f A)).
    enough (f (f A) <-> True) by firstorder.
    apply inj; firstorder.
- now_show (f (f (f A))).
  enough (f A <-> f (f (f A))) by firstorder.
  apply ext.
  split; intro H'.
  + now_show (f (f A)).
    enough (f A <-> f (f A)) by firstorder.
    apply ext; firstorder.
  + now_show A.
    enough (f A <-> A) by firstorder.
    apply inj; firstorder.
Defined.


Require Export Str.

Section NFA.

Record sym : Type := mkSym {
    symb :> finStr;
    _ : symb ∈ ([set [::x]| x in [set : symbol]] ∪ [set ϵ]);
}.

Definition ϵ_ : sym.
    apply (mkSym nil).
    rewrite inE; apply /orP; right.
    rewrite inE => //.
Qed.

Definition toSym (a : symbol) : sym.
Proof.
    apply (mkSym [:: a]).
    rewrite inE; apply /orP; left.
    apply /imsetP; exists a => //.
Qed.

Variable state : finType.
Variables Q F : {set state}.
Hypotheses FQ : F ⊂ Q.
Variable p0 : state.
Hypotheses pQ : p0 ∈ Q.
Variable δ : state -> sym ->  {set state}.

Reserved Notation "p -ϵ-> q"(at level 50).
Inductive Closure : state -> state -> Prop :=
    | CL_refl p : p -ϵ-> p
    | CL_single p q : q ∈ δ p ϵ_ -> p -ϵ-> q
    | CL_trans p q r : p -ϵ-> q -> q -ϵ-> r ->  p -ϵ-> r
    where "p -ϵ-> q" := (Closure p q).

Axiom closure : {set state} -> {set state}.
Axiom closureP : forall (P : {set state}) q,
    reflect (forall p, p ∈ P -> p -ϵ-> q) (q ∈ closure P).

Fixpoint δ' (p : state) (s : finStr) : {set state} :=
    match s with
    | [::] => closure [set p]
    | a :: w => closure (bigcup [set δ x (toSym a) | x in δ' p w])
    end.

Definition L := [set w : finStr | (δ' p0 w ∩ F) == ∅].

End NFA.


Require Import Reals.
Require Import Ensembles.
Require Import Lra.
Local Open Scope R.

(**Let D be the set [0,1] cup {2} cup [3,4). Show that any function f : D -> R is continuous at 2 *)
(*must roll my own continuity, to play w Ensembles-as-Types*)

Record Aset (A : Ensemble R) : Type := mkset {x :> R; inA : A x}.

Definition D (x : R) :=
  0 <= x <= 1 \/ x = 2 \/ 3 <= x < 4.

Lemma two_is_in_D : D 2.
Proof.
  unfold D.
  lra.
Qed.

Definition Aconverges (A : Ensemble R) (Un : nat -> Aset A) (c : Aset A) :=
  (*convergence of a sequence when every element is a member of a certain set*)
  forall eps,
    eps > 0 ->
    exists N, forall n, (n >= N)%nat -> R_dist (Un n) c < eps.

Definition continuous_pt (A : Ensemble R) (f : Aset A -> R) (c : Aset A) :=
  (*sequential characterization of convergence*)
  (*Un_cv is the standard library definition of convergence on R*)
  forall (Xn : nat -> Aset A), Aconverges A Xn c -> Un_cv (fun n => f (Xn n)) (f c).

Axiom equality :
  (*equality in R - Theorem 1.2.6 in Abbott*)
  forall x y eps, Rabs (x - y) < eps <-> x = y.

Axiom equality' :
  (*equality in a set A - Theorem 1..2.6 in Abbott*)
  forall (A : Ensemble R) (x y : Aset A) (eps : R), Rabs (x - y) < eps <-> x = y.

Axiom uniqueness' :
  (*I feel like this ought to be a part of the theory, so it may not be necessary for me to declare it as an axiom*)
  forall (A : Ensemble R) (f : Aset A -> R) (x y : Aset A), x = y -> f x = f y.

Theorem continuous_at_2 : forall (f : Aset D -> R), continuous_pt D f (mkset D 2 two_is_in_D).
Proof.
  intros f Xn H.
  unfold Aconverges in H.
  unfold Un_cv.
  intros eps H__eps.
  specialize (H eps H__eps).
  destruct H as [N H].
  exists N.
  intros n H__n.
  specialize (H n H__n).

  unfold R_dist in *.
  apply equality.
  apply equality' in H.
  apply uniqueness'.
  apply H.
Qed.


Require Import ZArith.
From mathcomp Require Import ssrbool ssreflect.

Set Implicit Arguments.

Inductive Typ :=
| Int
| Bool.

Definition const (a : Typ) : Type :=
  match a with
  | Int => nat
  | Bool => bool
  end.

Record ref (a : Typ) : Type :=
  { addr : nat; init : const a }.

Definition dec_eq_typ (a b : Typ) : decidable (a = b).
Proof. rewrite /decidable. repeat decide equality. Defined.