Require Export misc.
Require Export Zstruct.
Require Export ZArith.
Require Import Omega.
Require Import ZArithRing.
Require Import Zcomplements.
Require Import Zdiv.

Unset Standard Proposition Elimination Names.

Lemma gcd_unicity_apart_sign :
 forall a b c d : Z,
 is_gcd Z IdZ Zmult 0%Z a b c ->
 is_gcd Z IdZ Zmult 0%Z a b d -> d = c \/ d = (- c)%Z.
Proof.
intros.
elim
 (gcd_unicity_apart_unities Z IdZ Zplus Zmult 0%Z 1%Z Zopp
    Z_unitary_commutative_ring integrityZ a b c d H H0).
intros.
elim (inversibleZ x); intros.
left. elim H1; intros; elim H4; intros. rewrite H6. rewrite H2; auto with zarith.
right. elim H1; intros; elim H4; intros. rewrite H6. rewrite H2; auto with zarith.
elim H1; intros; exact H2.
Qed.

Lemma gcd_OZ_absZ : forall b : Z, is_gcd Z IdZ Zmult 0%Z 0%Z b (Zabs b).
Proof.
intros.
elim (Z_le_gt_dec 0 b); intros.
(* |b|=b *)
rewrite Zabs_eq; auto with zarith.
unfold is_gcd in |- *; split.
unfold divide in |- *; unfold IdZ in |- *; split. exact I. split. exact I. left; reflexivity.
split; unfold divide in |- *; unfold IdZ in |- *. split. exact I. split. exact I.
elim (Z_zerop b); intro y0.
left; exact y0.
right. split. exact y0. exists 1%Z. split. exact I. auto with zarith.
intros; exact H0.
(* |b|=(-b) *)
rewrite Zabs_non_eq; auto with zarith.
unfold is_gcd in |- *; split.
unfold divide in |- *; unfold IdZ in |- *; split. exact I. split. exact I. left; reflexivity.
split; unfold divide in |- *; unfold IdZ in |- *; split. exact I. split. exact I.
right. split; auto with zarith.
exists (-1)%Z; split. exact I.
auto with zarith.
exact I. split. exact I.
elim H0; intros; elim H2; intros; elim H4; intros. rewrite H5.
left; reflexivity.
right; split. elim H5; intros; exact H6. elim H5; intros; elim H7; intros.
exists (- x)%Z. split. exact I. elim H8; intros; rewrite H10.
rewrite <- Zopp_mult_distr_r; auto.
Qed.

Inductive is_gcdZ : Z -> Z -> Z -> Prop :=
  | gcd_OZ : forall b : Z, is_gcdZ 0%Z b (Zabs b)
  | gcd_mod :
      forall b a d q r : Z,
      b <> 0%Z ->
      (0 <= r < Zabs b)%Z ->
      a = (b * q + r)%Z -> is_gcdZ r b d -> is_gcdZ b a d.

Definition have_gcdZ (a b : Z) := {d : Z | is_gcdZ a b d}.

Definition gcdZ_i (a b : Z) := exist (is_gcdZ a b).

Definition P (a : Z) := forall b : Z, have_gcdZ a b.

Lemma acc_P : forall n : Z, (forall m : Z, (Zabs m < Zabs n)%Z -> P m) -> P n.
Proof.
  intros. case (Z_zerop n); intro. unfold P in |- *. intro.
  split with (Zabs b). rewrite e. apply (gcd_OZ b).
  unfold P in |- *; intro. elim (Zdiv_eucl_extended n0 b).
  intro p; elim p; intros q r H0; elim H0; clear p H0; intros.
  cut (Zabs r < Zabs n)%Z; intros.
  elim (H r H2 n). intros. split with x.
  apply gcd_mod with q r; trivial.
  rewrite Zabs_eq; auto with zarith.
Qed.

Lemma gcdZ_exists : forall a b : Z, have_gcdZ a b.
Proof.
  exact (Z_lt_abs_rec _ acc_P).
Qed.

Lemma gcdZ_is_gcd :
 forall a b d : Z, is_gcdZ a b d -> is_gcd Z IdZ Zmult 0%Z a b d.
Proof.
intros. elim H. intros. apply (gcd_OZ_absZ b0).
clear H a b d; intros. unfold is_gcd in |- *.
elim H3; clear H3; intros. elim H4; clear H4; intros. split. exact H4.
split. rewrite H1.
apply (div_add Z IdZ Zplus Zmult 0%Z Zopp Z_ring (b * q)%Z r d).
apply (div_mult Z IdZ Zplus Zmult 0%Z Zopp Z_ring b q d).
exact H4. exact I. exact H3.
intros. apply (H5 q0).
cut (r = (a - b * q)%Z); intros. rewrite H8.
apply (div_add Z IdZ Zplus Zmult 0%Z Zopp Z_ring a (- (b * q))%Z q0 H7).
apply (div_opp Z IdZ Zplus Zmult 0%Z Zopp Z_ring (b * q)%Z q0).
exact (div_mult Z IdZ Zplus Zmult 0%Z Zopp Z_ring b q q0 H6 I).
rewrite H1; auto with zarith.
exact H6.
Qed.

Definition gcdZ (a b : Z) := pi1 Z (is_gcdZ a b) (gcdZ_exists a b).

Theorem gcdZ_correct : forall a b : Z, is_gcdZ a b (gcdZ a b).
Proof.
exact (fun a b : Z => pi2 Z (is_gcdZ a b) (gcdZ_exists a b)).
Qed.

Lemma positive_is_gcdZ : forall a b d : Z, is_gcdZ a b d -> (0 <= d)%Z.
Proof.
intros; elim H; auto with zarith.
Qed.

Lemma unicity_is_gcdZ :
 forall a b c d : Z, is_gcdZ a b c -> is_gcdZ a b d -> d = c.
Proof.
intros.
elim
 (gcd_unicity_apart_sign a b c d (gcdZ_is_gcd a b c H) (gcdZ_is_gcd a b d H0)).
intros; exact H1.
intros.
cut (d = 0%Z).
intro eq; rewrite eq; rewrite eq in H1; auto with zarith.
apply Zle_antisym.
rewrite H1; set (c_pos := positive_is_gcdZ a b c H) in *.
omega.
set (d_pos := positive_is_gcdZ a b d H0) in *.
auto with zarith.
Qed.

Lemma gcdZ_is_gcdZ : forall a b d : Z, is_gcdZ a b d -> d = gcdZ a b.
Proof.
intros. apply (unicity_is_gcdZ a b (gcdZ a b) d (gcdZ_correct a b) H).
Qed.

Lemma gcd_modZ :
 forall a b q r : Z,
 b <> 0%Z -> (0 <= r < Zabs b)%Z -> a = (b * q + r)%Z -> gcdZ r b = gcdZ b a.
Proof.
intros. apply (gcdZ_is_gcdZ b a (gcdZ r b)).
apply (gcd_mod b a (gcdZ r b) q r H H0 H1 (gcdZ_correct r b)).
Qed.

Inductive verify_BezoutZ (a b : Z) : Set :=
    Bezout_i :
      forall u v : Z, (a * u + b * v)%Z = gcdZ a b -> verify_BezoutZ a b.

Definition Q (a : Z) := forall b : Z, verify_BezoutZ a b.

Lemma acc_Q : forall n : Z, (forall m : Z, (Zabs m < Zabs n)%Z -> Q m) -> Q n.
Proof.
  intros q f. elim (Z_zerop q); intro e. unfold Q in |- *; intro b.
  split with 1%Z (Zsgn b). rewrite e. simpl in |- *. rewrite (Zsgn_Zabs b).
  apply (gcdZ_is_gcdZ 0 b (Zabs b)); apply gcd_OZ. unfold Q in |- *; intro b.
  elim (Zdiv_eucl_extended e b). intro p; elim p; clear p.
  intros div r; intros. cut (Zabs r < Zabs q)%Z; intros.
  elim (f r H q). intros. split with (v + - (div * u))%Z u.
  elim p. intros. elim H1. intros. intros. pattern b at 1 in |- *.
  rewrite H0; auto with zarith.
  rewrite <- (gcd_modZ b q div r); auto with zarith.
  rewrite <- e0.
  ring.
  elim p; intros; elim H0; intros.
  rewrite Zabs_eq; auto with zarith.
Qed.

Lemma Bezout_exists : forall a b : Z, verify_BezoutZ a b.
Proof.
  exact (Z_lt_abs_rec _ acc_Q).
Qed.

Definition congruentZ (x y n : Z) := divide Z IdZ Zmult 0%Z n (x + - y)%Z.

Lemma divide_selfZ : forall x : Z, divide Z IdZ Zmult 0%Z x x.
Proof.
intros. unfold divide in |- *. split. exact I. split. exact I.
elim (Z_zerop x); intros. left; exact a.
right; split. exact b. exists 1%Z. split. exact I. auto with zarith.
Qed.

Theorem chinese_remaindering_theorem :
 forall a b x y : Z,
 gcdZ a b = 1%Z -> {z : Z | congruentZ z x a /\ congruentZ z y b}.
Proof.
intros. elim (Bezout_exists a b); intros.
exists (x * (b * v) + y * (a * u))%Z.
unfold congruentZ in |- *; split.
(* [congruentZ (z, x, a)] *)
rewrite H in e.
replace (x * (b * v) + y * (a * u) + - x)%Z with (a * (u * (y - x)))%Z.
unfold divide in |- *.
split. exact I. split. exact I.
elim (Z_zerop a); intros.
left; rewrite a0; auto with zarith.
right; split; trivial; exists (u * (y - x))%Z; auto with zarith.
split. exact I. reflexivity.
replace (b * v)%Z with (1 + - (a * u))%Z; auto with zarith.
ring.
(* [congruentZ (z, y, b)] *)
rewrite H in e.
replace (x * (b * v) + y * (a * u) + - y)%Z with (b * (v * (x - y)))%Z.
unfold divide in |- *.
split. exact I. split. exact I.
elim (Z_zerop b); intros.
left; rewrite a0; auto with zarith.
right; split; trivial; exists (v * (x - y))%Z; auto with zarith.
split. exact I. reflexivity.
replace (a * u)%Z with (1 + - (b * v))%Z; auto with zarith.
ring.
Qed.


From Coq Require Import ZArith.
Require Import Coq.ZArith.Zpow_facts.
Require Import coqutil.Z.div_mod_to_equations.
Require Import coqutil.Z.Lia Btauto.
Require Import coqutil.Z.PushPullMod.
Require Coq.setoid_ring.Ring_theory.
Require Import coqutil.Z.bitblast.
Require Import coqutil.Word.Interface. Import word.

Local Open Scope Z_scope.

Local Ltac mia := Z.div_mod_to_equations; Lia.nia.

Module word.
  Section WithWord. Local Set Default Proof Using "All".
    Context {width} {word : word width} {word_ok : word.ok word}.
    Local Hint Mode word.word - : typeclass_instances.

    (* Create HintDb word_laws discriminated. *) (* DON'T do this, COQBUG(5381) *)
    Hint Rewrite
       unsigned_of_Z signed_of_Z of_Z_unsigned unsigned_add unsigned_sub unsigned_opp unsigned_or unsigned_and unsigned_xor unsigned_not unsigned_ndn unsigned_mul signed_mulhss signed_mulhsu unsigned_mulhuu unsigned_divu signed_divs unsigned_modu signed_mods unsigned_slu unsigned_sru signed_srs unsigned_eqb unsigned_ltu signed_lts
       using trivial
  : word_laws.

    Lemma wrap_unsigned x : (unsigned x) mod (2^width) = unsigned x.
    Proof.
      pose proof unsigned_of_Z (unsigned x) as H.
      rewrite of_Z_unsigned in H. unfold wrap in *. congruence.
    Qed.

    Lemma unsigned_of_Z_0 : word.unsigned (word.of_Z 0) = 0.
    Proof.
      rewrite word.unsigned_of_Z; cbv [wrap]; rewrite Z.mod_small; trivial; [].
      split; try blia.
      epose proof proj1 (Z.pow_gt_1 2 width ltac:(blia)) word.width_pos; blia.
    Qed.

    Lemma unsigned_inj x y (H : unsigned x = unsigned y) : x = y.
    Proof. rewrite <-(of_Z_unsigned x), <-(of_Z_unsigned y). apply f_equal, H. Qed.

    Lemma unsigned_of_Z_nowrap x:
      0 <= x < 2 ^ width -> word.unsigned (word.of_Z x) = x.
    Proof.
      intros. rewrite word.unsigned_of_Z. unfold word.wrap. rewrite Z.mod_small; trivial.
    Qed.

    Lemma of_Z_inj_small{x y}:
      word.of_Z x = word.of_Z y -> 0 <= x < 2 ^ width -> 0 <= y < 2 ^ width -> x = y.
    Proof.
      intros. apply (f_equal word.unsigned) in H. rewrite ?word.unsigned_of_Z in H.
      unfold word.wrap in H. rewrite ?Z.mod_small in H by assumption. assumption.
    Qed.

    Lemma signed_eq_swrap_unsigned x : signed x = swrap (unsigned x).
    Proof. cbv [wrap]; rewrite <-signed_of_Z, of_Z_unsigned; trivial. Qed.

    Lemma width_nonneg : 0 <= width. pose proof width_pos. blia. Qed.
    Let width_nonneg_context : 0 <= width. apply width_nonneg. Qed.
    Lemma modulus_pos : 0 < 2^width. apply Z.pow_pos_nonneg; firstorder idtac. Qed.
    Let modulus_pos_section_context := modulus_pos.

    Lemma unsigned_range x : 0 <= unsigned x < 2^width.
    Proof. rewrite <-wrap_unsigned. mia. Qed.

    Lemma ring_theory : Ring_theory.ring_theory (of_Z 0) (of_Z 1) add mul sub opp Logic.eq.
    Proof.
     split; intros; apply unsigned_inj; repeat (rewrite ?wrap_unsigned,
         ?unsigned_add, ?unsigned_sub, ?unsigned_opp, ?unsigned_mul, ?unsigned_of_Z,
         ?Z.add_mod_idemp_l, ?Z.add_mod_idemp_r, ?Z.mul_mod_idemp_l, ?Z.mul_mod_idemp_r,
         ?Z.add_0_l, ?(Z.mod_small 1), ?Z.mul_1_l || unfold wrap);
       f_equal; auto with zarith.
    Qed.

    Ltac prove_ring_morph :=
      intros; apply unsigned_inj; repeat ((rewrite ?wrap_unsigned,
         ?unsigned_add, ?unsigned_sub, ?unsigned_opp, ?unsigned_mul, ?unsigned_of_Z,
         ?Z.add_mod_idemp_l, ?Z.add_mod_idemp_r, ?Z.mul_mod_idemp_l, ?Z.mul_mod_idemp_r,
         ?Zdiv.Zminus_mod_idemp_l, ?Zdiv.Zminus_mod_idemp_r,
         ?Z.sub_0_l, ?Z.add_0_l, ?(Z.mod_small 1), ?Z.mul_1_l by auto with zarith) || unfold wrap);
       try solve [f_equal; auto with zarith].
    Lemma ring_morph_add : forall x y : Z, of_Z (x + y) = add (of_Z x) (of_Z y).
    Proof. prove_ring_morph. Qed.
    Lemma ring_morph_sub : forall x y : Z, of_Z (x - y) = sub (of_Z x) (of_Z y).
    Proof. prove_ring_morph. Qed.
    Lemma ring_morph_mul : forall x y : Z, of_Z (x * y) = mul (of_Z x) (of_Z y).
    Proof. prove_ring_morph. Qed.
    Lemma ring_morph_opp : forall x : Z, of_Z (- x) = opp (of_Z x).
    Proof.
      prove_ring_morph.
      rewrite <-Z.sub_0_l; symmetry; rewrite <-Z.sub_0_l, Zdiv.Zminus_mod_idemp_r. auto.
    Qed.
    Lemma ring_morph_eqb : forall x y : Z, Zbool.Zeq_bool x y = true -> of_Z x = of_Z y.
    Proof. intros. f_equal. apply Zbool.Zeq_is_eq_bool. assumption. Qed.
    Lemma ring_morph :
      Ring_theory.ring_morph (of_Z 0) (of_Z 1) add   mul   sub   opp   Logic.eq
                             0        1        Z.add Z.mul Z.sub Z.opp Zbool.Zeq_bool of_Z.
    Proof.
      split; auto using ring_morph_add, ring_morph_sub, ring_morph_mul,
                        ring_morph_opp, ring_morph_eqb.
    Qed.

    Ltac generalize_wrap_unsigned :=
      repeat match goal with
             | x : @word.rep ?a ?b |- _ =>
               rewrite <-(wrap_unsigned x);
               let x' := fresh in
               set (unsigned x) as x' in *; clearbody x'; clear x; rename x' into x
             end.

    Lemma unsigned_mulhuu_nowrap x y : unsigned (mulhuu x y) = Z.mul (unsigned x) (unsigned y) / 2^width.
    Proof. autorewrite with word_laws; unfold wrap; generalize_wrap_unsigned; rewrite Z.mod_small; mia. Qed.
    Lemma unsigned_divu_nowrap x y (H:unsigned y <> 0) : unsigned (divu x y) = Z.div (unsigned x) (unsigned y).
    Proof. autorewrite with word_laws; unfold wrap; generalize_wrap_unsigned; rewrite Z.mod_small; mia. Qed.
    Lemma unsigned_modu_nowrap x y (H:unsigned y <> 0) : unsigned (modu x y) = Z.modulo (unsigned x) (unsigned y).
    Proof. autorewrite with word_laws; unfold wrap; generalize_wrap_unsigned; rewrite Z.mod_small; mia. Qed.

    Ltac bitwise :=
      autorewrite with word_laws;
      unfold wrap;
      generalize_wrap_unsigned;
      Z.bitblast.

    Lemma unsigned_or_nowrap x y : unsigned (or x y) = Z.lor (unsigned x) (unsigned y).
    Proof. bitwise. Qed.
    Lemma unsigned_and_nowrap x y : unsigned (and x y) = Z.land (unsigned x) (unsigned y).
    Proof. bitwise. Qed.
    Lemma unsigned_xor_nowrap x y : unsigned (xor x y) = Z.lxor (unsigned x) (unsigned y).
    Proof. bitwise. Qed.
    Lemma unsigned_ndn_nowrap x y : unsigned (ndn x y) = Z.ldiff (unsigned x) (unsigned y).
    Proof. bitwise. Qed.
    Lemma unsigned_sru_nowrap x y (H:unsigned y < width) : unsigned (sru x y) = Z.shiftr (unsigned x) (unsigned y).
    Proof.
      pose proof unsigned_range y.
      rewrite unsigned_sru by blia.
      unfold wrap.
      rewrite <-(wrap_unsigned x).
      Z.bitblast.
    Qed.

    Lemma testbit_wrap z i : Z.testbit (wrap z) i = ((i <? width) && Z.testbit z i)%bool.
    Proof. cbv [wrap]. Z.rewrite_bitwise; trivial. Qed.

    Lemma eqb_true: forall (a b: word), word.eqb a b = true -> a = b.
    Proof.
      intros.
      rewrite word.unsigned_eqb in H. rewrite Z.eqb_eq in H. apply unsigned_inj in H.
      assumption.
    Qed.

    Lemma eqb_eq: forall (a b: word), a = b -> word.eqb a b = true.
    Proof.
      intros. subst. rewrite unsigned_eqb. apply Z.eqb_refl.
    Qed.

    Lemma eqb_false: forall (a b: word), word.eqb a b = false -> a <> b.
    Proof.
      intros. intro. rewrite eqb_eq in H; congruence.
    Qed.

    Lemma eqb_ne: forall (a b: word), a <> b -> word.eqb a b = false.
    Proof.
      intros. destruct (word.eqb a b) eqn: E; try congruence.
      exfalso. apply H. apply eqb_true in E. assumption.
    Qed.

    Lemma eqb_spec(a b: word): BoolSpec (a = b) (a <> b) (word.eqb a b).
    Proof.
      destruct (eqb a b) eqn: E; constructor.
      - eauto using eqb_true.
      - eauto using eqb_false.
    Qed.

    Lemma eq_or_neq (k1 k2 : word) : k1 = k2 \/ k1 <> k2.
    Proof. destruct (word.eqb k1 k2) eqn:H; [eapply eqb_true in H | eapply eqb_false in H]; auto. Qed.

    Let width_nonzero : 0 < width. apply width_pos. Qed.
    Lemma half_modulus_pos : 0 < 2^(width-1). apply Z.pow_pos_nonneg; auto with zarith. Qed.
    Let half_modulus_pos_section_context := half_modulus_pos.
    Let twice_halfm : 2^(width-1) * 2 = 2^width.
    Proof. rewrite Z.mul_comm, <-Z.pow_succ_r by blia; f_equal; blia. Qed.

    Lemma unsigned_of_Z_1 : word.unsigned (word.of_Z 1) = 1.
    Proof.
      rewrite word.unsigned_of_Z; cbv [wrap]; rewrite Z.mod_small; trivial; []; blia.
    Qed.

    Lemma unsigned_of_Z_minus1 : word.unsigned (word.of_Z (-1)) = Z.ones width.
    Proof.
      rewrite word.unsigned_of_Z; cbv [wrap].
      change (-1) with (Z.opp 1).
      rewrite Z.mod_opp_l_nz; rewrite ?Z.mod_small; try blia; [].
      rewrite Z.ones_equiv.
      eapply Z.sub_1_r.
    Qed.

    Lemma signed_range x : -2^(width-1) <= signed x < 2^(width-1).
    Proof.
      rewrite signed_eq_swrap_unsigned. cbv [swrap].
      rewrite <-twice_halfm. mia.
    Qed.

    Lemma swrap_inrange z (H : -2^(width-1) <= z < 2^(width-1)) : swrap z = z.
    Proof. cbv [swrap]; rewrite Z.mod_small; blia. Qed.

    Lemma swrap_as_div_mod z : swrap z = z mod 2^(width-1) - 2^(width-1) * (z / (2^(width - 1)) mod 2).
    Proof.
      symmetry; cbv [swrap wrap].
      replace (2^width) with ((2 ^ (width - 1) * 2))
        by (rewrite Z.mul_comm, <-Z.pow_succ_r by blia; f_equal; blia).
      replace (z + 2^(width-1)) with (z + 1*2^(width-1)) by blia.
      rewrite Z.rem_mul_r, ?Z.div_add, ?Z.mod_add, (Z.add_mod _ 1 2), Zdiv.Zmod_odd by blia.
      destruct (Z.odd _); cbn; blia.
    Qed.

    Lemma pow2_width_minus1: 2 ^ width = 2 * 2 ^ (width - 1).
    Proof. rewrite <-Z.pow_succ_r, Z.sub_1_r, Z.succ_pred; blia. Qed.

    Ltac prove_signed_op :=
      rewrite !signed_eq_swrap_unsigned;
      autorewrite with word_laws;
      cbv [wrap swrap];
      rewrite pow2_width_minus1;
      Z.mod_equality.

    Lemma signed_add x y : signed (add x y) = swrap (Z.add (signed x) (signed y)).
    Proof. prove_signed_op. Qed.

    Lemma signed_sub x y : signed (sub x y) = swrap (Z.sub (signed x) (signed y)).
    Proof. prove_signed_op. Qed.

    Lemma signed_opp x : signed (opp x) = swrap (Z.opp (signed x)).
    Proof. prove_signed_op. Qed.

    Lemma signed_mul x y : signed (mul x y) = swrap (Z.mul (signed x) (signed y)).
    Proof. prove_signed_op. Qed.

    Lemma testbit_swrap z i : Z.testbit (swrap z) i
                              = if i <? width
                                then Z.testbit (wrap z) i
                                else Z.testbit (wrap z) (width -1).
    Proof.
      destruct (ZArith_dec.Z_lt_le_dec i 0).
      { destruct (Z.ltb_spec i width); rewrite ?Z.testbit_neg_r by blia; trivial. }
      rewrite swrap_as_div_mod. cbv [wrap].
      rewrite <-Z.testbit_spec' by blia.
      rewrite <-Z.add_opp_r.
      rewrite Z.add_nocarry_lxor; cycle 1.
      { destruct (Z.testbit z (width - 1)) eqn:Hw1; cbn [Z.b2z];
          rewrite ?Z.mul_1_r, ?Z.mul_0_r, ?Z.opp_0, ?Z.add_0_r, ?Z.land_0_r;
          [|solve[trivial]].
        Z.bitblast. }
      autorewrite with z_bitwise_no_hyps z_bitwise_with_hyps;
      destruct (Z.testbit z (width - 1)) eqn:Hw1; cbn [Z.b2z];
        rewrite ?Z.mul_1_r, ?Z.mul_0_r, ?Z.opp_0, ?Z.add_0_r, ?Z.land_0_r;
        autorewrite with z_bitwise_no_hyps z_bitwise_with_hyps; cbn [Z.pred];
        destruct (Z.ltb_spec i (width-1)), (Z.ltb_spec i width) ,(Z.ltb_spec (width-1) width) ; cbn; blia || btauto || trivial.
      { assert (i = width-1) by blia; congruence. }
      { assert (i = width-1) by blia; congruence. }
    Qed.

    Lemma testbit_signed x i : Z.testbit (signed x) i
                               = if i <? width
                                 then Z.testbit (unsigned x) i
                                 else Z.testbit (unsigned x) (width -1).
    Proof.
      rewrite <-wrap_unsigned, signed_eq_swrap_unsigned.
      eapply testbit_swrap; assumption.
    Qed.

    Hint Rewrite testbit_signed testbit_wrap testbit_swrap
         using solve [auto with zarith] : z_bitwise_signed.

    Ltac sbitwise :=
      eapply Z.bits_inj'; intros ?i ?Hi;
      autorewrite with word_laws z_bitwise_signed z_bitwise_no_hyps z_bitwise_with_hyps;
      repeat match goal with |- context [?a <? ?b] =>
        destruct (Z.ltb_spec a b); trivial; try blia
      end.

    Lemma swrap_signed x : swrap (signed x) = signed x.
    Proof. rewrite signed_eq_swrap_unsigned. sbitwise. Qed.

    Lemma signed_or x y (H : Z.lt (unsigned y) width) : signed (or x y) = swrap (Z.lor (signed x) (signed y)).
    Proof. sbitwise. Qed.
    Lemma signed_and x y : signed (and x y) = swrap (Z.land (signed x) (signed y)).
    Proof. sbitwise. Qed.
    Lemma signed_xor x y : signed (xor x y) = swrap (Z.lxor (signed x) (signed y)).
    Proof. sbitwise. Qed.
    Lemma signed_not x : signed (not x) = swrap (Z.lnot (signed x)).
    Proof. sbitwise. Qed.
    Lemma signed_ndn x y : signed (ndn x y) = swrap (Z.ldiff (signed x) (signed y)).
    Proof. sbitwise. Qed.

    Lemma signed_or_nowrap x y (H : Z.lt (unsigned y) width) : signed (or x y) = Z.lor (signed x) (signed y).
    Proof. sbitwise. Qed.
    Lemma signed_and_nowrap x y : signed (and x y) = Z.land (signed x) (signed y).
    Proof. sbitwise. Qed.
    Lemma signed_xor_nowrap x y : signed (xor x y) = Z.lxor (signed x) (signed y).
    Proof. sbitwise. Qed.
    Lemma signed_not_nowrap x : signed (not x) = Z.lnot (signed x).
    Proof. sbitwise. Qed.
    Lemma signed_ndn_nowrap x y : signed (ndn x y) = Z.ldiff (signed x) (signed y).
    Proof. sbitwise. Qed.

    Lemma signed_srs_nowrap x y (H:unsigned y < width) : signed (srs x y) = Z.shiftr (signed x) (unsigned y).
    Proof.
      pose proof unsigned_range y; sbitwise.
      replace (unsigned y) with 0 by blia; rewrite Z.add_0_r; trivial.
    Qed.

    Lemma signed_mulhss_nowrap x y : signed (mulhss x y) = Z.mul (signed x) (signed y) / 2^width.
    Proof. rewrite signed_mulhss. apply swrap_inrange. pose (signed_range x); pose (signed_range y). mia. Qed.
    Lemma signed_mulhsu_nowrap x y : signed (mulhsu x y) = Z.mul (signed x) (unsigned y) / 2^width.
    Proof. rewrite signed_mulhsu. apply swrap_inrange. pose (signed_range x); pose proof (unsigned_range y). mia. Qed.
    Lemma signed_divs_nowrap x y (H:signed y <> 0) (H0:signed x <> -2^(width-1) \/ signed y <> -1) : signed (divs x y) = Z.quot (signed x) (signed y).
    Proof.
      rewrite signed_divs by assumption. apply swrap_inrange.
      rewrite Z.quot_div by assumption. pose proof (signed_range x).
      destruct (Z.sgn_spec (signed x)) as [[? X]|[[? X]|[? X]]];
      destruct (Z.sgn_spec (signed y)) as [[? Y]|[[? Y]|[? Y]]];
      rewrite ?X, ?Y; rewrite ?Z.abs_eq, ?Z.abs_neq by blia; mia.
    Qed.
    Lemma signed_mods_nowrap x y (H:signed y <> 0) : signed (mods x y) = Z.rem (signed x) (signed y).
    Proof.
      rewrite signed_mods by assumption. apply swrap_inrange.
      rewrite Z.rem_mod by assumption.
      pose (signed_range x); pose (signed_range y).
      destruct (Z.sgn_spec (signed x)) as [[? X]|[[? X]|[? X]]];
      destruct (Z.sgn_spec (signed y)) as [[? Y]|[[? Y]|[? Y]]];
      rewrite ?X, ?Y; repeat rewrite ?Z.abs_eq, ?Z.abs_neq by blia; mia.
    Qed.

    Lemma signed_inj x y (H : signed x = signed y) : x = y.
    Proof.
      eapply unsigned_inj, Z.bits_inj'; intros i Hi.
      eapply (f_equal (fun z => Z.testbit z i)) in H.
      rewrite 2testbit_signed in H. rewrite <-(wrap_unsigned x), <-(wrap_unsigned y).
      autorewrite with word_laws z_bitwise_signed z_bitwise_no_hyps z_bitwise_with_hyps.
      destruct (Z.ltb_spec i width); auto.
    Qed.

    Lemma of_Z_signed: forall x: word, of_Z (signed x) = x.
    Proof.
      intros.
      apply signed_inj.
      rewrite signed_of_Z.
      apply swrap_signed.
    Qed.

    Lemma signed_of_Z_nowrap x :
      - 2^(width-1) <= x < 2 ^ (width-1) -> word.signed (word.of_Z x) = x.
    Proof.
      intros; rewrite signed_of_Z. cbv [swrap]; rewrite Z.mod_small; Lia.lia.
    Qed.

    Lemma signed_eqb x y : eqb x y = Z.eqb (signed x) (signed y).
    Proof.
      rewrite unsigned_eqb.
      destruct (Z.eqb_spec (unsigned x) (unsigned y)) as [?e|?];
        destruct (Z.eqb_spec (  signed x) (  signed y)) as [?e|?];
        try (apply unsigned_inj in e || apply signed_inj in e); congruence.
    Qed.
  End WithWord.

  Section WordConvenienceKitchenSink. Local Set Default Proof Using "All".
    Context {width} {word : word width} {word_ok : word.ok word}.
    Local Hint Mode word.word - : typeclass_instances.
    Lemma word_sub_add_l_same_l x y : word.sub (word.add x y) x = y.
    Proof.
      eapply word.unsigned_inj.
      rewrite <- (wrap_unsigned y), unsigned_sub, unsigned_add;
        cbv [wrap]; rewrite Zdiv.Zminus_mod_idemp_l. f_equal; blia.
    Qed.
    Lemma word_sub_add_l_same_r x y : word.sub (word.add y x) x = y.
    Proof.
      eapply word.unsigned_inj.
      rewrite <- (wrap_unsigned y), unsigned_sub, unsigned_add;
        cbv [wrap]; rewrite Zdiv.Zminus_mod_idemp_l; f_equal; blia.
    Qed.

    Lemma decrement_nonzero_lt x (H : word.unsigned x <> 0) :
      word.unsigned (word.sub x (word.of_Z 1)) < word.unsigned x.
    Proof.
      pose proof word.unsigned_range x; pose proof modulus_pos.
      rewrite word.unsigned_sub, word.unsigned_of_Z_1.
      unfold word.wrap. Z.div_mod_to_equations.
      enough (0 <= q); Lia.nia.
    Qed.

    Lemma well_founded_lt_unsigned : well_founded (fun a b : word => word.unsigned a < word.unsigned b).
    Proof.
      simple refine (Wf_nat.well_founded_lt_compat _ (fun x => Z.to_nat (word.unsigned x)) _ _).
      cbv beta; intros a b H.
      epose proof proj1 (Properties.word.unsigned_range a); epose proof proj1 (Properties.word.unsigned_range b).
      eapply Znat.Z2Nat.inj_lt; trivial.
      Unshelve.
      all: unfold word; typeclasses eauto.
    Qed.

    Lemma if_zero (t:bool) (H : unsigned (if t then of_Z 1 else of_Z 0) = 0) : t = false.
    Proof. destruct t; trivial; []. rewrite unsigned_of_Z_1 in H; inversion H. Qed.
    Lemma if_nonzero (t:bool) (H : unsigned (if t then of_Z 1 else of_Z 0) <> 0) : t = true.
    Proof. destruct t; trivial; []. rewrite unsigned_of_Z_0 in H. case (H eq_refl). Qed.

    Lemma unsigned_if: forall (b: bool) thn els,
        word.unsigned (if b then thn else els) = if b then word.unsigned thn else word.unsigned els.
    Proof. intros. destruct b; reflexivity. Qed.

    Lemma and_bool_to_word: forall (b1 b2: bool),
        word.and (if b1 then word.of_Z 1 else word.of_Z 0)
                 (if b2 then word.of_Z 1 else word.of_Z 0) =
        if (andb b1 b2) then word.of_Z 1 else word.of_Z 0.
    Proof.
      assert (1 < 2 ^ width). {
        pose proof word.width_pos.
        change 1 with (2 ^ 0). apply Z.pow_lt_mono_r; blia.
      }
      destruct b1; destruct b2; simpl; apply word.unsigned_inj; rewrite word.unsigned_and;
      unfold word.wrap; rewrite ?unsigned_of_Z_nowrap by blia;
        rewrite ?Z.land_diag, ?Z.land_0_r, ?Z.land_0_l;
        apply Z.mod_small; blia.
    Qed.

    Lemma or_bool_to_word: forall (b1 b2: bool),
        word.or (if b1 then word.of_Z 1 else word.of_Z 0)
                (if b2 then word.of_Z 1 else word.of_Z 0) =
        if (orb b1 b2) then word.of_Z 1 else word.of_Z 0.
    Proof.
      assert (1 < 2 ^ width). {
        pose proof word.width_pos.
        change 1 with (2 ^ 0). apply Z.pow_lt_mono_r; blia.
      }
      destruct b1; destruct b2; simpl; apply word.unsigned_inj; rewrite word.unsigned_or;
      unfold word.wrap; rewrite ?unsigned_of_Z_nowrap by blia;
        rewrite ?Z.land_diag, ?Z.land_0_r, ?Z.land_0_l;
        apply Z.mod_small; blia.
    Qed.

    Lemma unsigned_slu_shamtZ: forall (x: word) (a: Z),
        0 <= a < width ->
        word.unsigned (word.slu x (word.of_Z a)) = word.wrap (Z.shiftl (word.unsigned x) a).
    Proof.
      intros. assert (width <= 2 ^ width) by (apply Zpow_facts.Zpower2_le_lin; blia).
      rewrite word.unsigned_slu; rewrite word.unsigned_of_Z; unfold word.wrap; rewrite (Z.mod_small a); blia.
    Qed.

    Lemma unsigned_sru_shamtZ: forall (x: word) (a: Z),
        0 <= a < width ->
        word.unsigned (word.sru x (word.of_Z a)) = Z.shiftr (word.unsigned x) a.
    Proof.
      intros. assert (width <= 2 ^ width) by (apply Zpow_facts.Zpower2_le_lin; blia).
      rewrite word.unsigned_sru_nowrap; rewrite word.unsigned_of_Z;
        unfold word.wrap; rewrite (Z.mod_small a); blia.
    Qed.

    Lemma signed_srs_shamtZ: forall (x: word) (a: Z),
        0 <= a < width ->
        word.signed (word.srs x (word.of_Z a)) = Z.shiftr (word.signed x) a.
    Proof.
      intros. assert (width <= 2 ^ width) by (apply Zpow_facts.Zpower2_le_lin; blia).
      rewrite word.signed_srs_nowrap; rewrite word.unsigned_of_Z;
        unfold word.wrap; rewrite (Z.mod_small a); blia.
    Qed.

    Add Ring wring: (@word.ring_theory width word word_ok).

    Lemma add_assoc: forall (x y z: word), word.add x (word.add y z) = word.add (word.add x y) z.
    Proof. intros. ring. Qed.
    Lemma mul_assoc: forall (x y z: word), word.mul x (word.mul y z) = word.mul (word.mul x y) z.
    Proof. intros. ring. Qed.

    Lemma of_Z_inj_mod: forall x y,
        x mod 2 ^ width = y mod 2 ^ width ->
        word.of_Z x = word.of_Z y.
    Proof.
      intros.
      apply word.unsigned_inj.
      rewrite ?word.unsigned_of_Z.
      unfold word.wrap.
      assumption.
    Qed.

    Lemma of_Z_eq_by_moddiff0: forall x y,
        (x - y) mod 2 ^ width = 0 ->
        word.of_Z x = word.of_Z y.
    Proof.
      intros. apply of_Z_inj_mod.
      apply Z.mod_divide in H; cycle 1. {
        pose proof word.width_pos.
        apply Z.pow_nonzero; blia.
      }
      unfold Z.divide in H.
      destruct H as [k H].
      apply Z.sub_move_r in H.
      subst x.
      rewrite <- Zplus_mod_idemp_l.
      rewrite Z_mod_mult.
      rewrite Z.add_0_l.
      reflexivity.
    Qed.

  End WordConvenienceKitchenSink.
End word.

Require Import coqutil.Decidable.

#[global] Existing Instance word.eqb_spec.

(* Ring Helpers: *)

Ltac word_cst w :=
  match w with
  | word.of_Z ?x => let b := isZcst x in
                    match b with
                    | true => x
                    | _ => constr:(NotConstant)
                    end
  | _ => constr:(NotConstant)
  end.

#[global] Hint Rewrite
  @word.ring_morph_add
  @word.ring_morph_sub
  @word.ring_morph_mul
  @word.ring_morph_opp
  using typeclasses eauto
  : rew_word_morphism.

Section RingDemoAndTest. Local Set Default Proof Using "All".

  Context {width: Z} {word: word.word width} {word_ok: word.ok word}.
    Local Hint Mode word.word - : typeclass_instances.

  Add Ring wring : (word.ring_theory (word := word))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (word.ring_morph (word := word)),
       constants [word_cst]).

  (* These test cases show that the above extra options for "Add Ring" are indeed needed:
     Remove any of them and something below will break. *)
  Goal False.
    assert (forall (w1 w2: word), word.add w1 w2 = word.add w2 w1) as A.
    { intros. ring. } clear A.

    assert (forall (z: Z) (w: word),
               word.add w (word.mul (word.of_Z 4)
                                    (word.sub (word.of_Z (1 + z + 1)) (word.of_Z z))) =
               word.add (word.add w (word.of_Z 4)) (word.of_Z 4)) as A.
    { intros. ring. } clear A.

    assert (forall (L : Z) (w : word),
               word.add w (word.of_Z ((L + 2) * 4)) =
               word.add (word.add (word.add w (word.of_Z 4))
                                  (word.mul (word.of_Z 4) (word.of_Z L)))
                        (word.of_Z 4)) as A.
    { intros. ring. } clear A.
  Abort.

  (* This test case illustrates why it's better to use Zbool.Zeq_bool instead of Z.eqb
     when defining word.ring_morph.
     "Add Ring" adds the option "sign get_signZ_th" by default, but get_signZ_th uses
     Zbool.Zeq_bool instead of Z.eqb, so if we use Z.eqb, the sign option fails and is
     ignored, and ring_simplify creates terms like "add x (mul (of_Z (-1)) y)"
     instead of just "sub x y". *)
  Goal False.
    assert (forall (w1 w2 w3: word),
               word.sub (word.add w1 w2) (word.add w2 w3) =
               word.sub w1 w3) as A.
    { intros. ring_simplify (sub (add w1 w2) (add w2 w3)). reflexivity. } clear A.
  Abort.

End RingDemoAndTest.


Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import compiler.util.Common.
Require Import compiler.NameGen.
Require Import Coq.NArith.NArith.
Require Import Coq.Numbers.DecimalString.
Require Import Coq.Numbers.DecimalN.

Local Open Scope string_scope.
Local Open Scope char_scope.
Local Open Scope N_scope.

Definition maxLength: list string -> nat :=
  List.fold_right (fun s res => max res (String.length s)) 0%nat.

(* reversed binary string *)
Fixpoint rev_binary_pos(p: positive): string :=
  match p with
  | xH => "1"
  | xO q => String "0" (rev_binary_pos q)
  | xI q => String "1" (rev_binary_pos q)
  end.

Definition rev_binary(n: N): string :=
  match n with
  | N.pos p => rev_binary_pos p
  | N0 => "0"
  end.

Lemma rev_binary_pos_nonempty: forall p,
    rev_binary_pos p <> ""%string.
Proof.
  destruct p; simpl; congruence.
Qed.

Lemma rev_binary_pos_inj: forall p p',
    rev_binary_pos p = rev_binary_pos p' ->
    p = p'.
Proof.
  induction p; intros; destruct p'; simpl in *; inversion H; try f_equal; eauto;
    exfalso; eapply rev_binary_pos_nonempty; try eassumption; symmetry; eassumption.
Qed.

Lemma rev_binary_pos_non_zero: forall p,
    rev_binary_pos p <> "0"%string.
Proof.
  destruct p; simpl; try congruence.
  intro C. inversion C. eapply rev_binary_pos_nonempty. eassumption.
Qed.

Lemma rev_binary_inj: forall n n',
    rev_binary n = rev_binary n' ->
    n = n'.
Proof.
  intros.
  destruct n; destruct n'; simpl in *.
  - try reflexivity.
  - symmetry in H. apply rev_binary_pos_non_zero in H. contradiction.
  - apply rev_binary_pos_non_zero in H. contradiction.
  - apply rev_binary_pos_inj in H. congruence.
Qed.

Lemma rev_binary_nonempty: forall n,
    rev_binary n <> ""%string.
Proof.
  unfold rev_binary. intros. destruct n.
  - congruence.
  - apply rev_binary_pos_nonempty.
Qed.

Lemma two_to_number_of_digits_lower_bound: forall n,
    n < 2 ^ N.of_nat (String.length (rev_binary n)).
Proof.
  intros. remember (rev_binary n) as s. revert dependent n.
  induction s; intros.
  - symmetry in Heqs. apply rev_binary_nonempty in Heqs. contradiction.
  - destruct n.
    + simpl in Heqs. inversion Heqs. subst. cbv. reflexivity.
    + simpl in Heqs. destruct p.
      * simpl in Heqs. inversion Heqs. subst.
        change (String.length (String "1" (rev_binary_pos p))) with
            (1 + (String.length (rev_binary_pos p)))%nat.
        rewrite Nat2N.inj_add.
        rewrite N.pow_add_r.
        change (2 ^ N.of_nat 1) with 2.
        change (N.pos p~1) with (1 + 2 * N.pos p).
        specialize (IHs (N.pos p) eq_refl). blia.
      * simpl in Heqs. inversion Heqs. subst.
        change (String.length (String "0" (rev_binary_pos p))) with
            (1 + (String.length (rev_binary_pos p)))%nat.
        rewrite Nat2N.inj_add.
        rewrite N.pow_add_r.
        change (2 ^ N.of_nat 1) with 2.
        change (N.pos p~1) with (1 + 2 * N.pos p).
        specialize (IHs (N.pos p) eq_refl). blia.
      * simpl in Heqs. inversion Heqs. subst.
        cbv. reflexivity.
Qed.

Definition start_state(l: list string): N := 2 ^ N.of_nat (maxLength l).

Definition fresh_string_var(state: N): string * N :=
  (String "x" (rev_binary state), state + 1).

Definition all_from(state: N): string -> Prop :=
  fun v => exists state', String "x" (rev_binary state') = v /\ state <= state'.

Lemma fresh_string_var_spec: forall (s s' : N) (x : string),
    fresh_string_var s = (x, s') ->
    PropSet.elem_of x (all_from s) /\
    ~ PropSet.elem_of x (all_from s') /\
    PropSet.subset (all_from s') (all_from s).
Proof.
  unfold fresh_string_var, all_from, PropSet.subset, PropSet.elem_of; intros.
  inversion H; subst; clear H. ssplit.
  - eexists. split; reflexivity.
  - intro C. destruct C as [s' [E H]].
    inversion E. clear E.
    apply rev_binary_inj in H1. blia.
  - intros. destruct H as [s' [E H]]. subst x.
    eexists. split; [reflexivity|]. blia.
Qed.

Lemma start_state_spec: forall (l : list string) (v : string),
    In v l -> ~ PropSet.elem_of v (all_from (start_state l)).
Proof.
  unfold fresh_string_var, all_from, start_state, PropSet.subset, PropSet.elem_of; intros.
  intro C. destruct C as [state [E C]]. subst v.
  revert dependent l. induction l; simpl; intros.
  - assumption.
  - destruct H.
    + subst. simpl in *.
      assert (2 ^ (N.of_nat (S (String.length (rev_binary state)))) <= state) as A. {
        eapply N.le_trans. 2: eassumption.
        apply N.pow_le_mono_r; blia.
      }
      replace (N.of_nat (S (String.length (rev_binary state)))) with
          (1 + N.of_nat (String.length (rev_binary state))) in A by blia.
      rewrite N.pow_add_r in A.
      change (2 ^ 1) with 2 in A.
      pose proof (two_to_number_of_digits_lower_bound state).
      blia.
    + eapply IHl. 1: eassumption.
      eapply N.le_trans. 2: eassumption.
      apply N.pow_le_mono_r; blia.
Qed.

#[global] Instance StringNameGen: NameGen string N := {|
  freshNameGenState := start_state;
  genFresh := fresh_string_var;
  allFreshVars := all_from;
  genFresh_spec := fresh_string_var_spec;
  freshNameGenState_spec := start_state_spec;
|}.


Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Init.Decimal.

Open Scope list.

Fixpoint option_list_map{A B:Type}(f:A -> option B)(l:list A) : list B :=
match l with
|nil => nil
|x :: xs => match f x with
            |None => (option_list_map f xs)
            |Some b => b :: (option_list_map f xs)
            end
end.

Open Scope string_scope.

(*if s begins with prefix, returns the rest of the string, otherwise none*)
Fixpoint clear_prefix (s prefix:string) : option string :=
  match s, prefix with
  | _, "" => Some s
  | "", String _ _ => None
  | String hd_s tl_s, String hd_p tl_p =>
           if Ascii.eqb hd_s hd_p
            then clear_prefix tl_s tl_p
            else None
  end.

Fixpoint read_uint (s:string) : option uint :=
match s with
|""           => Some Nil
|String hd tl =>
                (match hd with
                 |"0"%char => option_map D0
                 |"1"%char => option_map D1
                 |"2"%char => option_map D2
                 |"3"%char => option_map D3
                 |"4"%char => option_map D4
                 |"5"%char => option_map D5
                 |"6"%char => option_map D6
                 |"7"%char => option_map D7
                 |"8"%char => option_map D8
                 |"9"%char => option_map D9
                 |_ => fun _:_ => None
                 end) (read_uint tl)
end.

Definition read_nat := fun s:_ => option_map Nat.of_uint (read_uint s).

Fixpoint split_string (s:string)(sep:ascii) : list string :=
match s with
|"" => nil
|String hd tl => if Ascii.eqb hd sep
                  then "" :: (split_string tl sep)
                  else match (split_string tl sep) with
                       |nil => (String hd "") :: nil
                       |cons x xs => (String hd x) :: xs
                       end
end.

Inductive sub_instruction : Set :=
 up : nat -> sub_instruction
|down : nat -> sub_instruction
|forward : nat -> sub_instruction.

Definition read_sub_instruction(s:string) : option sub_instruction.
destruct (clear_prefix s "up ").
destruct (read_nat s0).
apply (Some (up n)).
apply None.

destruct (clear_prefix s "down ").
destruct (read_nat s0).
apply (Some (down n)).
apply None.

destruct (clear_prefix s "forward ").
destruct (read_nat s0).
apply (Some (forward n)).
apply None.

apply None.
Optimize Proof.
Defined.

Require Import Coq.ZArith.ZArith.

Open Scope Z.
Open Scope list.

Fixpoint find_position (course : list sub_instruction) : Z*Z :=
match course with
|nil => (0, 0)
|x :: xs => match (find_position xs) with
            |(n, m) => match x with
                       |up k => (n, m - (BinIntDef.Z.of_nat k))
                       |down k => (n, m + (BinIntDef.Z.of_nat k))
                       |forward k => (n + (BinIntDef.Z.of_nat k), m)
                       end
            end
end.

Require Import Day2_puzzle_input.

Compute (fun p:Z*Z => match p with |(n, m) => n * m end) (find_position (option_list_map read_sub_instruction (split_string Day2_puzzle_input "010"%char))).

Fixpoint find_position_aim_helper (course : list sub_instruction)(hor depth aim:Z) : Z*Z*Z :=
match course with
|nil => (hor, depth, aim)
|x :: xs => let p := match x with
                     |up k => (0, 0, - (BinIntDef.Z.of_nat k))
                     |down k => (0, 0, BinIntDef.Z.of_nat k)
                     |forward k => ((BinIntDef.Z.of_nat k), aim * (BinIntDef.Z.of_nat k), 0)
                     end in
            match p with
            |(hor_delta, depth_delta, aim_delta) => find_position_aim_helper xs (hor + hor_delta) (depth + depth_delta) (aim + aim_delta)
            end
end.

Definition find_position_aim (course : list sub_instruction) : Z*Z*Z := find_position_aim_helper course 0 0 0.

Compute (fun p:Z*Z*Z => match p with |(n, m, _) => n * m end) (find_position_aim (option_list_map read_sub_instruction (split_string Day2_puzzle_input "010"%char))).


Require Import XR_Rsqr.
Require Import XR_Ropp_0.
Require Import XR_Rle_or_lt.
Require Import XR_Rsqr_neg_pos_le_1.
Require Import XR_Rlt_irrefl.
Require Import XR_Rlt_le_trans.
Require Import XR_Rle_trans.
Require Import XR_Ropp_le_contravar.

Local Open Scope R_scope.

Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y.
Proof.
  intros x y.
  intros hyx hxy.
  destruct (Rle_or_lt R0 y) as [ hy | hy ].
  {
    apply Rsqr_neg_pos_le_1.
    { exact hyx. }
    { exact hxy. }
    { exact hy. }
  }
  {
    exfalso.
    apply Rlt_irrefl with y.
    apply Rlt_le_trans with R0.
    { exact hy. }
    {
      apply Rle_trans with x.
      {
        apply Rle_trans with (-y).
        {
          rewrite <- Ropp_0.
          apply Ropp_le_contravar.
          left.
          exact hy.
        }
        { exact hyx. }
      }
      { exact hxy. }
    }
  }
Qed.


Require Import Basics.
Require Import Diagrams.Diagram.
Require Import Diagrams.Graph.
Require Import Diagrams.Cone.
Require Import Diagrams.ConstantDiagram.

Local Open Scope path_scope.
Generalizable All Variables.

(** This file contains the definition of limits, and functoriality results on limits. *)

(** * Limits *)

(** A Limit is the extremity of a cone. *)

Class IsLimit `(D : Diagram G) (Q : Type) := {
  islimit_cone : Cone Q D;
  islimit_unicone : UniversalCone islimit_cone;
}.
(* Use :> and remove the two following lines,
   once Coq 8.16 is the minimum required version. *)
#[export] Existing Instance islimit_cone.
Coercion islimit_cone : IsLimit >-> Cone.

Arguments Build_IsLimit {G D Q} C H : rename.
Arguments islimit_cone {G D Q} C : rename.
Arguments islimit_unicone {G D Q} H : rename.

(** [cone_precompose_inv] is defined for convenience: it is only the inverse of [cone_precompose]. It allows to recover the map [h] from a cone [C']. *)

Definition cone_precompose_inv `{D: Diagram G} {Q X}
  (H : IsLimit D Q) (C' : Cone X D) : X -> Q
  := @equiv_inv _ _ _ (islimit_unicone H X) C'.

(** * Existence of limits *)

Record Limit `(D : Diagram G) := {
  lim : forall i, D i;
  limp : forall i j (g : G i j), D _f g (lim i) = lim j;
}.

Arguments lim {_ _}.
Arguments limp {_ _}.

Definition cone_limit `(D : Diagram G) : Cone (Limit D) D.
Proof.
  srapply Build_Cone.
  + intros i x.
    apply (lim x i).
  + intros i j g x.
    apply limp.
Defined.

Global Instance unicone_limit `(D : Diagram G)
  : UniversalCone (cone_limit D).
Proof.
  srapply Build_UniversalCone; intro Y.
  srapply isequiv_adjointify.
  { intros c y.
    srapply Build_Limit.
    { intro i.
      apply (legs c i y). }
    intros i j g.
    apply legs_comm. }
  all: intro; reflexivity.
Defined.

Global Instance islimit_limit `(D : Diagram G) : IsLimit D (Limit D)
  := Build_IsLimit (cone_limit _) _.

(** * Functoriality of limits *)

Section FunctorialityLimit.

  Context `{Funext} {G : Graph}.

  (** Limits are preserved by composition with a (diagram) equivalence. *)

  Definition islimit_precompose_equiv {D : Diagram G} `(f : Q <~> Q')
    : IsLimit D Q' -> IsLimit D Q.
  Proof.
    intros HQ.
    srapply (Build_IsLimit (cone_precompose HQ f) _).
    apply cone_precompose_equiv_universality, HQ.
  Defined.

  Definition islimit_postcompose_equiv {D1 D2 : Diagram G} (m : D1 ~d~ D2)
    {Q : Type} : IsLimit D1 Q -> IsLimit D2 Q.
  Proof.
    intros HQ.
    srapply (Build_IsLimit (cone_postcompose m HQ) _).
    apply cone_postcompose_equiv_universality, HQ.
  Defined.

  (** A diagram map [m] : [D1] => [D2] induces a map between any two limits of [D1] and [D2]. *)

  Definition functor_limit {D1 D2 : Diagram G} (m : DiagramMap D1 D2)
    {Q1 Q2} (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2)
    : Q1 -> Q2 := cone_precompose_inv HQ2 (cone_postcompose m HQ1).

  (** And this map commutes with diagram map. *)

  Definition functor_limit_commute {D1 D2 : Diagram G}
    (m : DiagramMap D1 D2) {Q1 Q2}
    (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2)
    : cone_postcompose m HQ1
      = cone_precompose HQ2 (functor_limit m HQ1 HQ2)
    := (eisretr (cone_precompose HQ2) _)^.

  (** ** Limits of equivalent diagrams *)

  (** Now we have than two equivalent diagrams have equivalent limits. *)

  Context {D1 D2 : Diagram G} (m : D1 ~d~ D2) {Q1 Q2}
    (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2).

  Definition functor_limit_eissect
    : functor_limit m HQ1 HQ2
      o functor_limit (diagram_equiv_inv m) HQ2 HQ1 == idmap.
  Proof.
    apply ap10.
    srapply (equiv_inj (cone_precompose HQ2) _).
    1: apply HQ2.
    etransitivity.
    2:symmetry; apply cone_precompose_identity.
    etransitivity.
    1: apply cone_precompose_comp.
    rewrite eisretr, cone_postcompose_precompose, eisretr.
    rewrite cone_postcompose_comp, diagram_inv_is_section.
    apply cone_postcompose_identity.
  Defined.

  Definition functor_limit_eisretr
    : functor_limit (diagram_equiv_inv m) HQ2 HQ1
      o functor_limit m HQ1 HQ2 == idmap.
  Proof.
    apply ap10.
    srapply (equiv_inj (cone_precompose HQ1) _).
    1: apply HQ1.
    etransitivity.
    2:symmetry; apply cone_precompose_identity.
    etransitivity.
    1: apply cone_precompose_comp.
    rewrite eisretr, cone_postcompose_precompose, eisretr.
    rewrite cone_postcompose_comp, diagram_inv_is_retraction.
    apply cone_postcompose_identity.
  Defined.

  Global Instance isequiv_functor_limit
    : IsEquiv (functor_limit m HQ1 HQ2)
    := isequiv_adjointify _ _
      functor_limit_eissect functor_limit_eisretr.

  Definition equiv_functor_limit : Q1 <~> Q2
    := Build_Equiv _ _ _ isequiv_functor_limit.

End FunctorialityLimit.

(** * Unicity of limits *)

(** A particuliar case of the functoriality result is that all limits of a diagram are equivalent (and hence equal in presence of univalence). *)

Theorem limit_unicity `{Funext} {G : Graph} {D : Diagram G} {Q1 Q2 : Type}
  (HQ1 : IsLimit D Q1) (HQ2 : IsLimit D Q2)
  : Q1 <~> Q2.
Proof.
  srapply equiv_functor_limit.
  srapply (Build_diagram_equiv (diagram_idmap D)).
Defined.

(** * Limits are right adjoint to constant diagram *)

Theorem limit_adjoint `{Funext} {G : Graph} {D : Diagram G} {C : Type}
  : (C -> Limit D) <~> DiagramMap (diagram_const C) D.
Proof.
  srapply equiv_adjointify.
  { intro f.
    srapply Build_DiagramMap.
    { intros i c.
      apply lim, f, c. }
    intros i j g x.
    apply limp. }
  { intros [f p] c.
    srapply Build_Limit.
    { intro i.
      apply f, c. }
    intros i j g.
    apply p. }
  1,2: intro; reflexivity.
Defined.


Coq < Section Predicate015.

Coq < Require Import Classical.

Coq < Load CpdtTactics.

Coq < Goal forall (X : Type) (F G : X->Prop), (forall x : X, F x) \/ (forall x : X, G x) -> (forall x : X, F x \/ G x).
1 subgoal

  ============================
   forall (X : Type) (F G : X -> Prop),
   (forall x : X, F x) \/ (forall x : X, G x) -> forall x : X, F x \/ G x

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


Require Import SetoidClass Morphisms.
Require Import Views.Tactics.
Require Import Views.BasicSetoids.

Section SetOfDef.
 Context A `{A_setoid : Setoid A}.
 Record Setof := {
   elem :> A -> Prop;
   elem_morph : Proper (equiv ==> iff) elem
 }.
End SetOfDef.
Arguments elem {A} {A_setoid} s _.

Section SetOf.

Context {A} `{A_setoid : Setoid A}.

Instance elem_morphism (u:Setof A) :
    Proper (equiv ==> iff) (elem u).
destruct u; cbv; firstorder.
Qed.

Notation "a ∈ u" := (elem u a) (at level 50).

Definition setofeq (u v : Setof A) : Prop :=
   forall a, a ∈ u <-> a ∈ v.

Instance setofeq_equiv : Equivalence setofeq.
firstorder.
Qed.

Instance setof_setoid : Setoid (Setof A) := {equiv := setofeq}.

Instance elem_morphism2 :
    Proper (equiv ==> equiv ==> iff) elem.
repeat intro; rewrite (H x0); rewrite H0; tauto.
Qed.

Definition subsetof (u v : Setof A) : Prop :=
   forall a, a ∈ u -> a ∈ v.

Instance subsetof_preo : PreOrder subsetof.
firstorder.
Qed.

Instance subsetof_morphism : Proper (equiv ==> equiv ==> iff) subsetof.
firstorder.
Qed.

Import Basics.

Instance subsetof_transitive :
    Proper (subsetof --> subsetof ++> impl) subsetof.
firstorder.
Qed.

Instance elem_monotone : Proper (subsetof ==> equiv ==> impl) elem.
repeat intro.
rewr auto.
Qed.

Instance setof_po : PartialOrder equiv subsetof.
firstorder.
Qed.

Inductive setof_preunion (I : Setof A -> Prop) (e : A) : Prop :=
  | witness_union : forall u, I u -> e ∈ u
        -> setof_preunion I e.

Hint Resolve witness_union.

Instance setof_union_morph (I : Setof A -> Prop) :
    Proper (equiv ==> iff) (setof_preunion I).
intros x y H0.
firstorder; apply witness_union with u; rewr auto.
Qed.

Definition setof_union (I : Setof A -> Prop) :=
  {| elem := setof_preunion I |}.

Lemma setof_union_bound :
  forall (I : Setof A -> Prop) (x : Setof A),
        I x -> subsetof x (setof_union I).
intros I x H a H0.
simpl; apply witness_union with x; trivial.
Qed.

Lemma setof_union_lub :
  forall (I : Setof A -> Prop) (z : Setof A),
   (forall x : Setof A, I x -> subsetof x z) ->
                subsetof (setof_union I) z.
intros I x H a H0.
destruct H0; apply (H u H0); trivial.
Qed.

Definition setof_preintersection (I : Setof A -> Prop) (e : A) : Prop :=
  forall u, I u -> e ∈ u.

Instance setof_intersection_morph (I : Setof A -> Prop) :
    Proper (equiv ==> iff) (setof_preintersection I).
intros x y H0.
unfold setof_preintersection.
firstorder; rewr auto.
Qed.

Definition setof_intersection (I : Setof A -> Prop) :=
  {| elem := setof_preintersection I |}.

Lemma setof_intersection_bound :
  forall (I : Setof A -> Prop) (x : Setof A),
    I x -> subsetof (setof_intersection I) x.
firstorder.
Qed.

Lemma setof_intersection_glb :
  forall (I : Setof A -> Prop) (z : Setof A),
    (forall x : Setof A, I x -> subsetof z x) ->
        subsetof z (setof_intersection I).
intros.
unfold subsetof in *.
unfold setof_intersection.
simpl.
firstorder.
Qed.

Instance mkSetof_morph (s : A -> Prop) :
    Proper (equiv ==> iff)
      (fun a : A => exists b : A, s b /\ a == b).
intros x y H.
firstorder;
 exists x0; firstorder; rewr auto.
Qed.

Definition mkSetof (s : A -> Prop) : Setof A :=
  {| elem := (fun a => exists b, s b /\ a == b) |}.

Instance mkSetof_smorph : Proper
    (equiv ==> equiv) mkSetof.
  repeat intro.
  split; destruct 1 as [x']; exists x';
   intuition; apply H; trivial.
Qed.

Definition singleton x := mkSetof  (fun y => y==x).

Lemma single_elem {x y} : x ∈ singleton y -> x == y.
simpl. firstorder.
rewr trivial.
Qed.

Program Definition emptyset : Setof A
       := {| elem := fun x => False |}.
Solve Obligations using firstorder.

End SetOf.

Existing Instance elem_morphism2.
Existing Instance elem_monotone.
Existing Instance setof_setoid.
Existing Instance subsetof_morphism.
Existing Instance subsetof_transitive.
Existing Instance subsetof_preo.
Existing Instance mkSetof_smorph.

Notation "a ∈ u" := (elem u a) (at level 50).

Ltac singleel := repeat
  match goal with
   [H : elem (singleton ?Y) ?X |- _] =>
      generalize (single_elem H); clear H; intro H
  end.

Section SetOfs.
Context {A B} `{A_setoid : Setoid A} `{B_setoid : Setoid B}.

Instance so_map_morph_pre (f : A -> B) (u : Setof A) :
  Proper (equiv ==> iff)
   (fun b : B => exists a : A, elem u a /\ b == f a).
intros x y H.
firstorder; exists x0; firstorder; rewr auto.
Qed.

Definition so_map (f : A -> B) (u : Setof A) : Setof B:=
 {| elem := (fun b => exists a, elem u a /\ b == f a) |}.

Instance so_map_morph : Proper (eq ==> equiv ==> equiv) so_map.
intros f f' eq x y equiv a; subst f'.
simpl; push; ssubst; eauto.
Qed.

Section RelationMap.

Variable (R : A -> B -> Prop).
Context `{R_morphism : Proper _ (equiv ==> equiv ==> iff) R}.

Instance so_map_rel_morph (u : Setof A) :
  Proper (equiv ==> iff)
    (fun b => exists a, u a /\ R a b).
intros x y H.
firstorder; exists x0; firstorder; rewr auto.
Qed.

Definition so_map_rel (u : Setof A) : Setof B :=
 {| elem := (fun b => exists a, u a /\ R a b) |}.

Instance so_map_rel_morphism :
    Proper (setofeq ==> setofeq) so_map_rel.
intro.
unfold so_map_rel.
unfold setofeq.
simpl.
firstorder.
Qed.

Instance so_map_rel_monotone :
    Proper (subsetof ++> subsetof) so_map_rel.
unfold so_map_rel. intro. unfold subsetof.  simpl.
firstorder.
Qed.

End RelationMap.

Instance collapse_morph_pre {A} {_ : Setoid A} (aaa:(Setof (Setof A))):
  Proper (equiv ==> iff)
    (fun (a : A) => exists aa, elem aaa aa /\ elem aa a) .
push; repeat ssubst; eauto.
Qed.

Definition collapse {A} {_ : Setoid A}
  (aaa : (Setof (Setof A)))  : (Setof A)
  := {| elem := (fun (a : A) => exists aa, elem aaa aa /\ elem aa a) |}.

Instance collapse_morph {A} {_ : Setoid A} : Proper (equiv ==> equiv) collapse.
unfold collapse;
push; simpl in *; push; eexists; push; try eassumption.
rewrite <- H. eassumption.
rewrite H. eassumption.
Qed.

End SetOfs.

Existing Instance so_map_rel_morphism.
Existing Instance so_map_rel_monotone.


From Hammer Require Import Hammer.

Require Import List Setoid Permutation Sorted Orders.

Local Notation "[ ]" := nil.
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).

Open Scope bool_scope.

Local Coercion is_true : bool >-> Sortclass.

Module Sort (Import X:Orders.TotalLeBool').

Fixpoint merge l1 l2 :=
let fix merge_aux l2 :=
match l1, l2 with
| [], _ => l2
| _, [] => l1
| a1::l1', a2::l2' =>
if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
end
in merge_aux l2.

Fixpoint merge_list_to_stack stack l :=
match stack with
| [] => [Some l]
| None :: stack' => Some l :: stack'
| Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l)
end.

Fixpoint merge_stack stack :=
match stack with
| [] => []
| None :: stack' => merge_stack stack'
| Some l :: stack' => merge l (merge_stack stack')
end.

Fixpoint iter_merge stack l :=
match l with
| [] => merge_stack stack
| a::l' => iter_merge (merge_list_to_stack stack [a]) l'
end.

Definition sort := iter_merge [].

Local Notation Sorted := (LocallySorted leb) (only parsing).

Fixpoint SortedStack stack :=
match stack with
| [] => True
| None :: stack' => SortedStack stack'
| Some l :: stack' => Sorted l /\ SortedStack stack'
end.

Local Ltac invert H := inversion H; subst; clear H.

Fixpoint flatten_stack (stack : list (option (list t))) :=
match stack with
| [] => []
| None :: stack' => flatten_stack stack'
| Some l :: stack' => l ++ flatten_stack stack'
end.

Theorem Sorted_merge : forall l1 l2,
Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Sorted_merge".
induction l1; induction l2; intros; simpl; auto.
destruct (a <=? a0) eqn:Heq1.
invert H.
simpl. constructor; trivial; rewrite Heq1; constructor.
assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto).
clear H0 H3 IHl1; simpl in *.
destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor.
assert (a0 <=? a) by
(destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')).
invert H0.
constructor; trivial.
assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1.
clear IHl2; simpl in *.
destruct (a <=? b); constructor; auto.
Qed.

Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Permuted_merge".
induction l1; simpl merge; intro.
assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l)
as -> by (destruct l; trivial).
apply Permutation_refl.
induction l2.
rewrite app_nil_r. apply Permutation_refl.
destruct (a <=? a0).
constructor; apply IHl1.
apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2.
Qed.

Theorem Sorted_merge_list_to_stack : forall stack l,
SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Sorted_merge_list_to_stack".
induction stack as [|[|]]; intros; simpl.
auto.
apply IHstack. destruct H as (_,H1). fold SortedStack in H1. auto.
apply Sorted_merge; auto; destruct H; auto.
auto.
Qed.

Theorem Permuted_merge_list_to_stack : forall stack l,
Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Permuted_merge_list_to_stack".
induction stack as [|[]]; simpl; intros.
reflexivity.
rewrite app_assoc.
etransitivity.
apply Permutation_app_tail.
etransitivity.
apply Permutation_app_comm.
apply Permuted_merge.
apply IHstack.
reflexivity.
Qed.

Theorem Sorted_merge_stack : forall stack,
SortedStack stack -> Sorted (merge_stack stack).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Sorted_merge_stack".
induction stack as [|[|]]; simpl; intros.
constructor; auto.
apply Sorted_merge; tauto.
auto.
Qed.

Theorem Permuted_merge_stack : forall stack,
Permutation (flatten_stack stack) (merge_stack stack).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Permuted_merge_stack".
induction stack as [|[]]; simpl.
trivial.
transitivity (l ++ merge_stack stack).
apply Permutation_app_head; trivial.
apply Permuted_merge.
assumption.
Qed.

Theorem Sorted_iter_merge : forall stack l,
SortedStack stack -> Sorted (iter_merge stack l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Sorted_iter_merge".
intros stack l H; induction l in stack, H |- *; simpl.
auto using Sorted_merge_stack.
assert (Sorted [a]) by constructor.
auto using Sorted_merge_list_to_stack.
Qed.

Theorem Permuted_iter_merge : forall l stack,
Permutation (flatten_stack stack ++ l) (iter_merge stack l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Permuted_iter_merge".
induction l; simpl; intros.
rewrite app_nil_r. apply Permuted_merge_stack.
change (a::l) with ([a]++l).
rewrite app_assoc.
etransitivity.
apply Permutation_app_tail.
etransitivity.
apply Permutation_app_comm.
apply Permuted_merge_list_to_stack.
apply IHl.
Qed.

Theorem Sorted_sort : forall l, Sorted (sort l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Sorted_sort".
intro; apply Sorted_iter_merge. constructor.
Qed.

Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.LocallySorted_sort".   intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed.

Theorem Permuted_sort : forall l, Permutation l (sort l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.Permuted_sort".
intro; apply (Permuted_iter_merge l []).
Qed.

Corollary StronglySorted_sort : forall l,
Transitive leb -> StronglySorted leb (sort l).
Proof. hammer_hook "Mergesort" "Mergesort.Sort.StronglySorted_sort".   auto using Sorted_StronglySorted, LocallySorted_sort. Qed.

End Sort.

Module NatOrder <: TotalLeBool.
Definition t := nat.
Fixpoint leb x y :=
match x, y with
| 0, _ => true
| _, 0 => false
| S x', S y' => leb x' y'
end.
Infix "<=?" := leb (at level 35).
Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
Proof. hammer_hook "Mergesort" "Mergesort.NatOrder.leb_total".
induction a1; destruct a2; simpl; auto.
Qed.
End NatOrder.

Module Import NatSort := Sort NatOrder.

Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0].


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about Sigma-types (dependent sums) *)

Require Import HoTT.Basics.
Require Import Types.Arrow Types.Paths.
Local Open Scope path_scope.

Generalizable Variables X A B C f g n.

(** In homotopy type theory, We think of elements of [Type] as spaces, homotopy types, or weak omega-groupoids. A type family [P : A -> Type] corresponds to a fibration whose base is [A] and whose fiber over [x] is [P x].

From such a [P] we can build a total space over the base space [A] so that the fiber over [x : A] is [P x]. This is just Coq's dependent sum construction, written as [sig P] or [{x : A & P x}]. The elements of [{x : A & P x}] are pairs, written [exist P x y] in Coq, where [x : A] and [y : P x].  In [Common.v] we defined the notation [(x;y)] to mean [exist _ x y].

The base and fiber components of a point in the total space are extracted with the two projections [pr1] and [pr2]. *)

(** ** Unpacking *)

(** Sometimes we would like to prove [Q u] where [u : {x : A & P x}] by writing [u] as a pair [(pr1 u ; pr2 u)]. This is accomplished by [sig_unpack]. We want tight control over the proof, so we just write it down even though is looks a bit scary. *)

Definition unpack_sigma `{P : A -> Type} (Q : sig P -> Type) (u : sig P)
: Q (u.1; u.2) -> Q u
  := idmap.

Arguments unpack_sigma / .

(** ** Eta conversion *)

Definition eta_sigma `{P : A -> Type} (u : sig P)
  : (u.1; u.2) = u
  := 1.

Arguments eta_sigma / .

Definition eta2_sigma `{P : forall (a : A) (b : B a), Type}
           (u : sig (fun a => sig (P a)))
  : (u.1; u.2.1; u.2.2) = u
  := 1.

Arguments eta2_sigma / .

Definition eta3_sigma `{P : forall (a : A) (b : B a) (c : C a b), Type}
           (u : sig (fun a => sig (fun b => sig (P a b))))
  : (u.1; u.2.1; u.2.2.1; u.2.2.2) = u
  := 1.

Arguments eta3_sigma / .

(** ** Paths *)

(** A path in a total space is commonly shown component wise. Because we use this over and over, we write down the proofs by hand to make sure they are what we think they should be. *)

(** With this version of the function, we often have to give [u] and [v] explicitly, so we make them explicit arguments. *)
Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sig P)
           (pq : {p : u.1 = v.1 & p # u.2 = v.2})
: u = v
  := match pq.2 in (_ = v2) return u = (v.1; v2) with
       | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with
                | 1 => 1
              end
     end.

(** This is the curried one you usually want to use in practice.  We define it in terms of the uncurried one, since it's the uncurried one that is proven below to be an equivalence. *)
Definition path_sigma {A : Type} (P : A -> Type) (u v : sig P)
           (p : u.1 = v.1) (q : p # u.2 = v.2)
: u = v
  := path_sigma_uncurried P u v (p;q).

(** A contravariant instance of [path_sigma_uncurried] *)
Definition path_sigma_uncurried_contra {A : Type} (P : A -> Type) (u v : sig P)
           (pq : {p : u.1 = v.1 & u.2 = p^ # v.2})
: u = v
  := (path_sigma_uncurried P v u (pq.1^;pq.2^))^.

(** A variant of [Forall.dpath_forall] from which uses dependent sums to package things. It cannot go into [Forall] because [Sigma] depends on [Forall]. *)

Definition dpath_forall'
           {A : Type } (P : A -> Type) (Q: sig P -> Type) {x y : A} (h : x = y)
           (f : forall p, Q (x ; p)) (g : forall p, Q (y ; p))
:
  (forall p, transport Q (path_sigma P (x ; p) (y; _) h 1) (f p) = g (h # p))
    <~>
    (forall p, transportD P (fun x => fun p => Q ( x ; p)) h p (f p) = g (transport P h p)).
Proof.
  destruct h.
  apply 1%equiv.
Defined.

(** This version produces only paths between pairs, as opposed to paths between arbitrary inhabitants of dependent sum types.  But it has the advantage that the components of those pairs can more often be inferred, so we make them implicit arguments. *)
Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'}
           (p : x = x') (q : p # y = y')
: (x;y) = (x';y')
  := path_sigma P (x;y) (x';y') p q.

(** Projections of paths from a total space. *)

Definition pr1_path `{P : A -> Type} {u v : sig P} (p : u = v)
: u.1 = v.1
  :=
    ap pr1 p.
(* match p with idpath => 1 end. *)

Notation "p ..1" := (pr1_path p) : fibration_scope.

Definition pr2_path `{P : A -> Type} {u v : sig P} (p : u = v)
: p..1 # u.2 = v.2
  := (transport_compose P pr1 p u.2)^
     @ (@apD {x:A & P x} _ pr2 _ _ p).

Notation "p ..2" := (pr2_path p) : fibration_scope.

(** Now we show how these things compute. *)

Definition pr1_path_sigma_uncurried `{P : A -> Type} {u v : sig P}
           (pq : { p : u.1 = v.1 & p # u.2 = v.2 })
: (path_sigma_uncurried _ _ _ pq)..1 = pq.1.
Proof.
  destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in *.
  destruct pq as [p q].
  destruct p; simpl in q; destruct q; reflexivity.
Defined.

Definition pr2_path_sigma_uncurried `{P : A -> Type} {u v : sig P}
           (pq : { p : u.1 = v.1 & p # u.2 = v.2 })
: (path_sigma_uncurried _ _ _ pq)..2
  = ap (fun s => transport P s u.2) (pr1_path_sigma_uncurried pq) @ pq.2.
Proof.
  destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in *.
  destruct pq as [p q].
  destruct p; simpl in q; destruct q; reflexivity.
Defined.

Definition eta_path_sigma_uncurried `{P : A -> Type} {u v : sig P}
           (p : u = v)
: path_sigma_uncurried _ _ _ (p..1; p..2) = p.
Proof.
  destruct p. reflexivity.
Defined.

Lemma transport_pr1_path_sigma_uncurried
      `{P : A -> Type} {u v : sig P}
      (pq : { p : u.1 = v.1 & transport P p u.2 = v.2 })
      Q
: transport (fun x => Q x.1) (@path_sigma_uncurried A P u v pq)
  = transport _ pq.1.
Proof.
  destruct pq as [p q], u, v; simpl in *.
  destruct p, q; simpl in *.
  reflexivity.
Defined.

Definition pr1_path_sigma `{P : A -> Type} {u v : sig P}
           (p : u.1 = v.1) (q : p # u.2 = v.2)
: (path_sigma _ _ _ p q)..1 = p
  := pr1_path_sigma_uncurried (p; q).

(* Writing it the other way can help [rewrite]. *)
Definition ap_pr1_path_sigma {A:Type} {P : A -> Type} {u v : sig P}
           (p : u.1 = v.1) (q : p # u.2 = v.2)
  : ap pr1 (path_sigma _ _ _ p q) = p
  := pr1_path_sigma p q.

Definition pr2_path_sigma `{P : A -> Type} {u v : sig P}
           (p : u.1 = v.1) (q : p # u.2 = v.2)
: (path_sigma _ _ _ p q)..2
  = ap (fun s => transport P s u.2) (pr1_path_sigma p q) @ q
  := pr2_path_sigma_uncurried (p; q).

Definition eta_path_sigma `{P : A -> Type} {u v : sig P} (p : u = v)
: path_sigma _ _ _ (p..1) (p..2) = p
  := eta_path_sigma_uncurried p.

Definition transport_pr1_path_sigma
           `{P : A -> Type} {u v : sig P}
           (p : u.1 = v.1) (q : p # u.2 = v.2)
           Q
: transport (fun x => Q x.1) (@path_sigma A P u v p q)
  = transport _ p
  := transport_pr1_path_sigma_uncurried (p; q) Q.

(** This lets us identify the path space of a sigma-type, up to equivalence. *)

Global Instance isequiv_path_sigma `{P : A -> Type} {u v : sig P}
: IsEquiv (path_sigma_uncurried P u v) | 0.
Proof.
  simple refine (Build_IsEquiv
            _ _
            _ (fun r => (r..1; r..2))
            eta_path_sigma
            _ _).
  all: destruct u, v; intros [p q].
  all: simpl in *.
  all: destruct q, p; simpl in *.
  all: reflexivity.
Defined.

Definition equiv_path_sigma `(P : A -> Type) (u v : sig P)
: {p : u.1 = v.1 &  p # u.2 = v.2} <~> (u = v)
  := Build_Equiv _ _ (path_sigma_uncurried P u v) _.

(* A contravariant version of [isequiv_path_sigma'] *)
Global Instance isequiv_path_sigma_contra `{P : A -> Type} {u v : sig P}
  : IsEquiv (path_sigma_uncurried_contra P u v) | 0.
  apply (isequiv_adjointify (path_sigma_uncurried_contra P u v)
        (fun r => match r with idpath => (1; 1) end)).
- by intro r; induction r; destruct u as [u1 u2]; reflexivity.
- destruct u, v; intros [p q].
  simpl in *.
  destruct p; simpl in q.
  destruct q; reflexivity.
Defined.

(* A contravariant version of [equiv_path_sigma] *)
Definition equiv_path_sigma_contra {A : Type} `(P : A -> Type) (u v : sig P)
  : {p : u.1 = v.1 & u.2 = p^ # v.2} <~> (u = v)
  := Build_Equiv _ _ (path_sigma_uncurried_contra P u v) _.

(** This identification respects path concatenation. *)

Definition path_sigma_pp_pp {A : Type} (P : A -> Type) {u v w : sig P}
           (p1 : u.1 = v.1) (q1 : p1 # u.2 = v.2)
           (p2 : v.1 = w.1) (q2 : p2 # v.2 = w.2)
: path_sigma P u w (p1 @ p2)
             (transport_pp P p1 p2 u.2 @ ap (transport P p2) q1 @ q2)
  = path_sigma P u v p1 q1 @ path_sigma P v w p2 q2.
Proof.
  destruct u, v, w. simpl in *.
  destruct p1, p2, q1, q2.
  reflexivity.
Defined.

Definition path_sigma_pp_pp' {A : Type} (P : A -> Type)
           {u1 v1 w1 : A} {u2 : P u1} {v2 : P v1} {w2 : P w1}
           (p1 : u1 = v1) (q1 : p1 # u2 = v2)
           (p2 : v1 = w1) (q2 : p2 # v2 = w2)
: path_sigma' P (p1 @ p2)
              (transport_pp P p1 p2 u2 @ ap (transport P p2) q1 @ q2)
  = path_sigma' P p1 q1 @ path_sigma' P p2 q2
  := @path_sigma_pp_pp A P (u1;u2) (v1;v2) (w1;w2) p1 q1 p2 q2.

Definition path_sigma_p1_1p' {A : Type} (P : A -> Type)
           {u1 v1 : A} {u2 : P u1} {v2 : P v1}
           (p : u1 = v1) (q : p # u2 = v2)
: path_sigma' P p q
  = path_sigma' P p 1 @ path_sigma' P 1 q.
Proof.
  destruct p, q.
  reflexivity.
Defined.

(** [pr1_path] also commutes with the groupoid structure. *)

Definition pr1_path_1 {A : Type} {P : A -> Type} (u : sig P)
: (idpath u) ..1 = idpath (u .1)
  := 1.

Definition pr1_path_pp {A : Type} {P : A -> Type} {u v w : sig P}
           (p : u = v) (q : v = w)
: (p @ q) ..1 = (p ..1) @ (q ..1)
  := ap_pp _ _ _.

Definition pr1_path_V {A : Type} {P : A -> Type} {u v : sig P} (p : u = v)
: p^ ..1 = (p ..1)^
  := ap_V _ _.

(** Applying [exist] to one argument is the same as [path_sigma] with reflexivity in the first place. *)

Definition ap_exist {A : Type} (P : A -> Type) (x : A) (y1 y2 : P x)
           (q : y1 = y2)
: ap (exist P x) q = path_sigma' P 1 q.
Proof.
  destruct q; reflexivity.
Defined.

(** Dependent transport is the same as transport along a [path_sigma]. *)

Definition transportD_is_transport
           {A:Type} (B:A->Type) (C:sig B -> Type)
           (x1 x2:A) (p:x1=x2) (y:B x1) (z:C (x1;y))
: transportD B (fun a b => C (a;b)) p y z
  = transport C (path_sigma' B p 1) z.
Proof.
  destruct p. reflexivity.
Defined.

(** Applying a two variable function to a [path_sigma]. *)

Definition ap_path_sigma {A B} (P : A -> Type) (F : forall a : A, P a -> B)
           {x x' : A} {y : P x} {y' : P x'} (p : x = x') (q : p # y = y')
  : ap (fun w => F w.1 w.2) (path_sigma' P p q)
    = ap _ (moveL_transport_V _ p _ _ q)
         @ (transport_arrow_toconst _ _ _)^ @ ap10 (apD F p) y'.
Proof.
  destruct p, q; reflexivity.
Defined.
(* Remark: this is also equal to: *)
(*     = ap10 (apD F p^)^ y @ transport_arrow_toconst _ _ _ *)
(*                          @ ap (F x') (transport2 _ (inv_V p) y @ q). *)

(** And we can simplify when the first equality is [1]. *)
Lemma ap_path_sigma_1p {A B : Type} {P : A -> Type} (F : forall a, P a -> B)
      (a : A) {x y : P a} (p : x = y)
  : ap (fun w => F w.1 w.2) (path_sigma' P 1 p) = ap (fun z => F a z) p.
Proof.
  destruct p; reflexivity.
Defined.

(** Applying a function constructed with [sig_ind] to a [path_sigma] can be computed.  Technically this computation should probably go by way of a 2-variable [ap], and should be done in the dependently typed case. *)

Definition ap_sig_rec_path_sigma {A : Type} (P : A -> Type) {Q : Type}
           (x1 x2:A) (p:x1=x2) (y1:P x1) (y2:P x2) (q:p # y1 = y2)
           (d : forall a, P a -> Q)
: ap (sig_ind (fun _ => Q) d) (path_sigma' P p q)
  = (transport_const p _)^
    @ (ap ((transport (fun _ => Q) p) o (d x1)) (transport_Vp _ p y1))^

    @ (transport_arrow p _ _)^
    @ ap10 (apD d p) (p # y1)
      @ ap (d x2) q.
Proof.
  destruct p. destruct q. reflexivity.
Defined.

(** A path between paths in a total space is commonly shown component wise. *)

(** With this version of the function, we often have to give [u] and [v] explicitly, so we make them explicit arguments. *)
Definition path_path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sig P)
           (p q : u = v)
           (rs : {r : p..1 = q..1 & transport (fun x => transport P x u.2 = v.2) r p..2 = q..2})
: p = q.
Proof.
  destruct rs, p, u.
  etransitivity; [ | apply eta_path_sigma ].
  path_induction.
  reflexivity.
Defined.

(** This is the curried one you usually want to use in practice.  We define it in terms of the uncurried one, since it's the uncurried one that is proven below to be an equivalence. *)
Definition path_path_sigma {A : Type} (P : A -> Type) (u v : sig P)
           (p q : u = v)
           (r : p..1 = q..1)
           (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2)
: p = q
  := path_path_sigma_uncurried P u v p q (r; s).

(** ** Transport *)

(** The concrete description of transport in sigmas (and also pis) is rather trickier than in the other types.  In particular, these cannot be described just in terms of transport in simpler types; they require also the dependent transport [transportD].

  In particular, this indicates why "transport" alone cannot be fully defined by induction on the structure of types, although Id-elim/transportD can be (cf. Observational Type Theory).  A more thorough set of lemmas, along the lines of the present ones but dealing with Id-elim rather than just transport, might be nice to have eventually? *)

Definition transport_sigma {A : Type} {B : A -> Type} {C : forall a:A, B a -> Type}
           {x1 x2 : A} (p : x1 = x2) (yz : { y : B x1 & C x1 y })
: transport (fun x => { y : B x & C x y }) p yz
  = (p # yz.1 ; transportD _ _ p yz.1 yz.2).
Proof.
  destruct p.  destruct yz as [y z]. reflexivity.
Defined.

(** The special case when the second variable doesn't depend on the first is simpler. *)
Definition transport_sigma' {A B : Type} {C : A -> B -> Type}
           {x1 x2 : A} (p : x1 = x2) (yz : { y : B & C x1 y })
: transport (fun x => { y : B & C x y }) p yz =
  (yz.1 ; transport (fun x => C x yz.1) p yz.2).
Proof.
  destruct p. destruct yz. reflexivity.
Defined.

(** Or if the second variable contains a first component that doesn't depend on the first.  Need to think about the naming of these. *)

Definition transport_sigma_' {A : Type} {B C : A -> Type}
           {D : forall a:A, B a -> C a -> Type}
           {x1 x2 : A} (p : x1 = x2)
           (yzw : { y : B x1 & { z : C x1 & D x1 y z } })
: transport (fun x => { y : B x & { z : C x & D x y z } }) p yzw
  = (p # yzw.1 ; p # yzw.2.1 ; transportD2 _ _ _ p yzw.1 yzw.2.1 yzw.2.2).
Proof.
  destruct p. reflexivity.
Defined.

(** ** Functorial action *)

Definition functor_sigma `{P : A -> Type} `{Q : B -> Type}
           (f : A -> B) (g : forall a, P a -> Q (f a))
: sig P -> sig Q
  := fun u => (f u.1 ; g u.1 u.2).

Definition ap_functor_sigma `{P : A -> Type} `{Q : B -> Type}
           (f : A -> B) (g : forall a, P a -> Q (f a))
           (u v : sig P) (p : u.1 = v.1) (q : p # u.2 = v.2)
: ap (functor_sigma f g) (path_sigma P u v p q)
  = path_sigma Q (functor_sigma f g u) (functor_sigma f g v)
               (ap f p)
               ((transport_compose Q f p (g u.1 u.2))^
                @ (@ap_transport _ P (fun x => Q (f x)) _ _ p g u.2)^
                @ ap (g v.1) q).
Proof.
  destruct u as [u1 u2]; destruct v as [v1 v2]; simpl in p, q.
  destruct p; simpl in q.
  destruct q.
  reflexivity.
Defined.

(** ** Equivalences *)

Global Instance isequiv_functor_sigma `{P : A -> Type} `{Q : B -> Type}
         `{IsEquiv A B f} `{forall a, @IsEquiv (P a) (Q (f a)) (g a)}
: IsEquiv (functor_sigma f g) | 1000.
Proof.
  refine (isequiv_adjointify (functor_sigma f g)
                             (functor_sigma (f^-1)
                                            (fun x y => ((g (f^-1 x))^-1 ((eisretr f x)^ # y)))) _ _);
  intros [x y].
  - refine (path_sigma' _ (eisretr f x) _); simpl.
    abstract (
        rewrite (eisretr (g (f^-1 x)));
        apply transport_pV
      ).
  - refine (path_sigma' _ (eissect f x) _); simpl.
    refine ((ap_transport (eissect f x) (fun x' => (g x') ^-1)
                          (transport Q (eisretr f (f x)) ^ (g x y)))^ @ _).
    abstract (
        rewrite transport_compose, eisadj, transport_pV;
        apply eissect
      ).
Defined.

Definition equiv_functor_sigma `{P : A -> Type} `{Q : B -> Type}
           (f : A -> B) `{IsEquiv A B f}
           (g : forall a, P a -> Q (f a))
           `{forall a, @IsEquiv (P a) (Q (f a)) (g a)}
: sig P <~> sig Q
  := Build_Equiv _ _ (functor_sigma f g) _.

Definition equiv_functor_sigma' `{P : A -> Type} `{Q : B -> Type}
           (f : A <~> B)
           (g : forall a, P a <~> Q (f a))
: sig P <~> sig Q
  := equiv_functor_sigma f g.

Definition equiv_functor_sigma_id `{P : A -> Type} `{Q : A -> Type}
           (g : forall a, P a <~> Q a)
: sig P <~> sig Q
  := equiv_functor_sigma' 1 g.

Definition equiv_functor_sigma_pb {A B : Type} {Q : B -> Type}
           (f : A <~> B)
: sig (Q o f) <~> sig Q
  := equiv_functor_sigma f (fun a => 1%equiv).

(** Lemma 3.11.9(i): Summing up a contractible family of types does nothing. *)

Global Instance isequiv_pr1_contr {A} {P : A -> Type}
         `{forall a, Contr (P a)}
: IsEquiv (@pr1 A P) | 100.
Proof.
  refine (isequiv_adjointify (@pr1 A P)
                             (fun a => (a ; center (P a))) _ _).
  - intros a; reflexivity.
  - intros [a p].
    refine (path_sigma' P 1 (contr _)).
Defined.

Definition equiv_sigma_contr {A : Type} (P : A -> Type)
           `{forall a, Contr (P a)}
: sig P <~> A
  := Build_Equiv _ _ pr1 _.

(** Lemma 3.11.9(ii): Dually, summing up over a contractible type does nothing. *)

Definition equiv_contr_sigma {A : Type} (P : A -> Type) `{Contr A}
: { x : A & P x } <~> P (center A).
Proof.
  refine (equiv_adjointify (fun xp => (contr xp.1)^ # xp.2)
                           (fun p => (center A ; p)) _ _).
  - intros p; simpl.
    exact (ap (fun q => q # p) (path_contr _ 1)).
  - intros [a p].
    refine (path_sigma' _ (contr a) _).
    apply transport_pV.
Defined.

(** ** Associativity *)

(** All of the following lemmas are proven easily with the [make_equiv] tactic.  If you have a more complicated rearrangement of sigma-types to do, it is usually possible to do it by putting together these equivalences, but it is often simpler and faster to just use [make_equiv] directly. *)

Definition equiv_sigma_assoc `(P : A -> Type) (Q : {a : A & P a} -> Type)
  : {a : A & {p : P a & Q (a;p)}} <~> sig Q.
Proof.
  make_equiv.
Defined.

Definition equiv_sigma_assoc' `(P : A -> Type) (Q : forall a : A, P a -> Type)
  : {a : A & {p : P a & Q a p}} <~> {ap : sig P & Q ap.1 ap.2}.
Proof.
  make_equiv.
Defined.

Definition equiv_sigma_prod `(Q : (A * B) -> Type)
  : {a : A & {b : B & Q (a,b)}} <~> sig Q.
Proof.
  make_equiv.
Defined.

Definition equiv_sigma_prod0 (A B : Type)
  : {a : A & B} <~> A * B.
Proof.
  make_equiv.
Defined.

Definition equiv_sigma_prod1 (A B C : Type)
  : {a : A & {b : B & C}} <~> A * B * C
  := ltac:(make_equiv).

Definition equiv_sigma_prod_prod {X Y : Type} (P : X -> Type) (Q : Y -> Type)
  : {z : X * Y & (P (fst z)) * (Q (snd z))} <~> (sig P) * (sig Q)
  := ltac:(make_equiv).

(** ** Symmetry *)

Definition equiv_sigma_symm `(P : A -> B -> Type)
  : {a : A & {b : B & P a b}} <~> {b : B & {a : A & P a b}}.
Proof.
  make_equiv.
Defined.

Definition equiv_sigma_symm' {A : Type} `(P : A -> Type) `(Q : A -> Type)
  : { ap : { a : A & P a } & Q ap.1 } <~> { aq : { a : A & Q a } & P aq.1 }.
Proof.
  make_equiv.
Defined.

Definition equiv_sigma_symm0 (A B : Type)
: {a : A & B} <~> {b : B & A}.
Proof.
  make_equiv.
Defined.

(** ** Universal mapping properties *)

(** *** The positive universal property. *)
Global Instance isequiv_sig_ind `{P : A -> Type}
         (Q : sig P -> Type)
: IsEquiv (sig_ind Q) | 0
  := Build_IsEquiv
       _ _
       (sig_ind Q)
       (fun f x y => f (x;y))
       (fun _ => 1)
       (fun _ => 1)
       (fun _ => 1).

Definition equiv_sig_ind `{P : A -> Type}
           (Q : sig P -> Type)
: (forall (x:A) (y:P x), Q (x;y)) <~> (forall xy, Q xy)
  := Build_Equiv _ _ (sig_ind Q) _.

(** And a curried version *)
Definition equiv_sig_ind' `{P : A -> Type}
           (Q : forall a, P a -> Type)
: (forall (x:A) (y:P x), Q x y) <~> (forall xy, Q xy.1 xy.2)
  := equiv_sig_ind (fun xy => Q xy.1 xy.2).

(** *** The negative universal property. *)

Definition sig_coind_uncurried
           `{A : X -> Type} (P : forall x, A x -> Type)
: { f : forall x, A x & forall x, P x (f x) }
  -> (forall x, sig (P x))
  := fun fg => fun x => (fg.1 x ; fg.2 x).

Definition sig_coind
           `{A : X -> Type} (P : forall x, A x -> Type)
           (f : forall x, A x) (g : forall x, P x (f x))
: (forall x, sig (P x))
  := sig_coind_uncurried P (f;g).

Global Instance isequiv_sig_coind
         `{A : X -> Type} {P : forall x, A x -> Type}
: IsEquiv (sig_coind_uncurried P) | 0
  := Build_IsEquiv
       _ _
       (sig_coind_uncurried P)
       (fun h => exist (fun f => forall x, P x (f x))
                        (fun x => (h x).1)
                        (fun x => (h x).2))
       (fun _ => 1)
       (fun _ => 1)
       (fun _ => 1).

Definition equiv_sig_coind
           `(A : X -> Type) (P : forall x, A x -> Type)
: { f : forall x, A x & forall x, P x (f x) }
    <~> (forall x, sig (P x))
  := Build_Equiv _ _ (sig_coind_uncurried P) _.

(** ** Sigmas preserve truncation *)

Global Instance istrunc_sigma `{P : A -> Type}
         `{IsTrunc n A} `{forall a, IsTrunc n (P a)}
: IsTrunc n (sig P) | 100.
Proof.
  generalize dependent A.
  induction n; simpl; intros A P ac Pc.
  { exists (center A; center (P (center A))).
    intros [a ?].
    refine (path_sigma' P (contr a) (path_contr _ _)). }
  intros u v.
  refine (istrunc_isequiv_istrunc _ (path_sigma_uncurried P u v)).
Defined.

(** The sigma of an arbitrary family of *disjoint* hprops is an hprop. *)
Definition ishprop_sigma_disjoint
           `{P : A -> Type} `{forall a, IsHProp (P a)}
: (forall x y, P x -> P y -> x = y) -> IsHProp { x : A & P x }.
Proof.
  intros dj; apply hprop_allpath; intros [x px] [y py].
  refine (path_sigma' P (dj x y px py) _).
  apply path_ishprop.
Defined.

(** ** Subtypes (sigma types whose second components are hprops) *)

(** To prove equality in a subtype, we only need equality of the first component. *)
Definition path_sigma_hprop {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)}
           (u v : sig P)
: u.1 = v.1 -> u = v
  := path_sigma_uncurried P u v o pr1^-1.

Global Instance isequiv_path_sigma_hprop {A P} `{forall x : A, IsHProp (P x)} {u v : sig P}
: IsEquiv (@path_sigma_hprop A P _ u v) | 100
  := isequiv_compose.

#[export]
Hint Immediate isequiv_path_sigma_hprop : typeclass_instances.

Definition equiv_path_sigma_hprop {A : Type} {P : A -> Type}
           {HP : forall a, IsHProp (P a)} (u v : sig P)
: (u.1 = v.1) <~> (u = v)
  := Build_Equiv _ _ (path_sigma_hprop _ _) _.

Definition isequiv_pr1_path_hprop {A} {P : A -> Type}
         `{forall a, IsHProp (P a)}
         x y
: IsEquiv (@pr1_path A P x y)
  := _ : IsEquiv (path_sigma_hprop x y)^-1.

#[export]
Hint Immediate isequiv_pr1_path_hprop : typeclass_instances.

(** We define this for ease of [SearchAbout IsEquiv ap pr1] *)
Definition isequiv_ap_pr1_hprop {A} {P : A -> Type}
           `{forall a, IsHProp (P a)}
           x y
: IsEquiv (@ap _ _ (@pr1 A P) x y)
  := _.

(** [path_sigma_hprop] is functorial *)
Definition path_sigma_hprop_1 {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)} (u : sig P)
: path_sigma_hprop u u 1 = 1.
Proof.
  unfold path_sigma_hprop.
  unfold isequiv_pr1_contr; simpl.
  (** Ugh *)
  refine (ap (fun p => match p in (_ = v2) return (u = (u.1; v2)) with 1 => 1 end)
             (contr (idpath u.2))).
Defined.

Definition path_sigma_hprop_V {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)} {a b : A} (p : a = b)
           (x : P a) (y : P b)
: path_sigma_hprop (b;y) (a;x) p^ = (path_sigma_hprop (a;x) (b;y) p)^.
Proof.
  destruct p; simpl.
  rewrite (path_ishprop x y).
  refine (path_sigma_hprop_1 _ @ (ap inverse (path_sigma_hprop_1 _))^).
Qed.

Definition path_sigma_hprop_pp
           {A : Type}
           {P : A -> Type}
           `{forall x, IsHProp (P x)}
           {a b c : A}
           (p : a = b) (q : b = c)
           (x : P a) (y : P b) (z : P c)
: path_sigma_hprop (a;x) (c;z) (p @ q)
    =
  path_sigma_hprop (a;x) (b;y) p @ path_sigma_hprop (b;y) (c;z) q.
Proof.
  destruct p, q.
  rewrite (path_ishprop y x).
  rewrite (path_ishprop z x).
  refine (_ @ (ap (fun z => z @ _) (path_sigma_hprop_1 _))^).
  apply (concat_1p _)^.
Qed.

(** The inverse of [path_sigma_hprop] has its own name, so we give special names to the section and retraction homotopies to help [rewrite] out. *)
Definition path_sigma_hprop_ap_pr1 {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)} (u v : sig P) (p : u = v)
: path_sigma_hprop u v (ap pr1 p) = p
  := eisretr (path_sigma_hprop u v) p.
Definition path_sigma_hprop_pr1_path {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)} (u v : sig P) (p : u = v)
: path_sigma_hprop u v p..1 = p
  := eisretr (path_sigma_hprop u v) p.
Definition ap_pr1_path_sigma_hprop {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)} (u v : sig P) (p : u.1 = v.1)
: ap pr1 (path_sigma_hprop u v p) = p
  := eissect (path_sigma_hprop u v) p.
Definition pr1_path_path_sigma_hprop {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)} (u v : sig P) (p : u.1 = v.1)
: (path_sigma_hprop u v p)..1 = p
  := eissect (path_sigma_hprop u v) p.

(** ** Fibers of [functor_sigma] *)
Definition hfiber_functor_sigma {A B} (P : A -> Type) (Q : B -> Type)
           (f : A -> B) (g : forall a, P a -> Q (f a))
           (b : B) (v : Q b)
: (hfiber (functor_sigma f g) (b; v)) <~>
  {w : hfiber f b & hfiber (g w.1) ((w.2)^ # v)}.
Proof.
  unfold hfiber, functor_sigma.
  refine (_ oE equiv_functor_sigma_id _).
  2:intros; symmetry; apply equiv_path_sigma.
  transitivity {w : {x : A & f x = b} & {x : P w.1 & (w.2) # (g w.1 x) = v}}.
  1:make_equiv.
  apply equiv_functor_sigma_id; intros [a p]; simpl.
  apply equiv_functor_sigma_id; intros u; simpl.
  apply equiv_moveL_transport_V.
Defined.

Global Instance istruncmap_functor_sigma n {A B P Q}
       (f : A -> B) (g : forall a, P a -> Q (f a))
       {Hf : IsTruncMap n f} {Hg : forall a, IsTruncMap n (g a)}
  : IsTruncMap n (functor_sigma f g).
Proof.
  intros [a b].
  exact (istrunc_equiv_istrunc _ (hfiber_functor_sigma _ _ _ _ _ _)^-1).
Defined.

(** Theorem 4.7.6 *)
Definition hfiber_functor_sigma_idmap {A} (P Q : A -> Type)
           (g : forall a, P a -> Q a)
           (b : A) (v : Q b)
: (hfiber (functor_sigma idmap g) (b; v)) <~>
   hfiber (g b) v.
Proof.
  refine (_ oE hfiber_functor_sigma P Q idmap g b v).
  exact (equiv_contr_sigma
           (fun (w:hfiber idmap b) => hfiber (g w.1) (transport Q (w.2)^ v))).
Defined.

(** The converse and Theorem 4.7.7 can be found in Types/Equiv.v *)
Definition istruncmap_from_functor_sigma n {A P Q}
           (g : forall a : A, P a -> Q a)
           `{!IsTruncMap n (functor_sigma idmap g)}
  : forall a, IsTruncMap n (g a).
Proof.
  intros a v.
  exact (istrunc_equiv_istrunc _ (hfiber_functor_sigma_idmap _ _ _ _ _)).
Defined.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(** Bit vectors interpreted as integers.
    Contribution by Jean Duprat (ENS Lyon). *)

Require Import Bvector.
Require Import ZArith.
Require Export Zpower.
Require Import Omega.

(** The evaluation of boolean vector is done both in binary and
    two's complement. The computed number belongs to Z.
    We hence use Omega to perform computations in Z.
    Moreover, we use functions [2^n] where [n] is a natural number
    (here the vector length).
*)

Section VALUE_OF_BOOLEAN_VECTORS.

(** Computations are done in the usual convention.
    The values correspond either to the binary coding (nat) or
    to the two's complement coding (int).
    We perform the computation via Horner scheme.
    The two's complement coding only makes sense on vectors whose
    size is greater or equal to one (a sign bit should be present).
*)

  Definition bit_value (b:bool) : Z :=
    match b with
      | true => 1%Z
      | false => 0%Z
    end.

  Lemma binary_value : forall n:nat, Bvector n -> Z.
  Proof.
    refine (nat_rect _ _ _); intros.
    exact 0%Z.

    inversion H0.
    exact (bit_value h + 2 * H H2)%Z.
  Defined.

  Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
  Proof.
    simple induction n; intros.
    inversion H.
    exact (- bit_value h)%Z.

    inversion H0.
    exact (bit_value h + 2 * H H2)%Z.
  Defined.

End VALUE_OF_BOOLEAN_VECTORS.

Section ENCODING_VALUE.

(** We compute the binary value via a Horner scheme.
    Computation stops at the vector length without checks.
    We define a function Zmod2 similar to Z.div2 returning the
    quotient of division z=2q+r with 0<=r<=1.
    The two's complement value is also computed via a Horner scheme
    with Zmod2, the parameter is the size minus one.
*)

  Definition Zmod2 (z:Z) :=
    match z with
      | Z0 => 0%Z
      | Zpos p => match p with
		    | xI q => Zpos q
		    | xO q => Zpos q
		    | xH => 0%Z
		  end
      | Zneg p =>
	match p with
	  | xI q => (Zneg q - 1)%Z
	  | xO q => Zneg q
	  | xH => (-1)%Z
	end
    end.

  Lemma Zmod2_twice :
    forall z:Z, z = (2 * Zmod2 z + bit_value (Z.odd z))%Z.
  Proof.
    destruct z; simpl.
    trivial.

    destruct p; simpl; trivial.

    destruct p; simpl.
    destruct p as [p| p| ]; simpl.
    rewrite <- (Pos.pred_double_succ p); trivial.

    trivial.

    trivial.

    trivial.

    trivial.
  Qed.

  Lemma Z_to_binary : forall n:nat, Z -> Bvector n.
  Proof.
    simple induction n; intros.
    exact Bnil.

    exact (Bcons (Z.odd H0) n0 (H (Z.div2 H0))).
  Defined.

  Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
  Proof.
    simple induction n; intros.
    exact (Bcons (Z.odd H) 0 Bnil).

    exact (Bcons (Z.odd H0) (S n0) (H (Zmod2 H0))).
  Defined.

End ENCODING_VALUE.

Section Z_BRIC_A_BRAC.

  (** Some auxiliary lemmas used in the next section. Large use of ZArith.
      Deserve to be properly rewritten.
  *)

  Lemma binary_value_Sn :
    forall (n:nat) (b:bool) (bv:Bvector n),
      binary_value (S n) ( b :: bv) =
      (bit_value b + 2 * binary_value n bv)%Z.
  Proof.
    intros; auto.
  Qed.

  Lemma Z_to_binary_Sn :
    forall (n:nat) (b:bool) (z:Z),
      (z >= 0)%Z ->
      Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
  Proof.
    destruct b; destruct z; simpl; auto.
    intro H; elim H; trivial.
  Qed.

  Lemma binary_value_pos :
    forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
  Proof.
    induction bv as [| a n v IHbv]; cbn.
    omega.

    destruct a; destruct (binary_value n v); simpl; auto.
    auto with zarith.
  Qed.

  Lemma two_compl_value_Sn :
    forall (n:nat) (bv:Bvector (S n)) (b:bool),
      two_compl_value (S n) (Bcons b (S n) bv) =
      (bit_value b + 2 * two_compl_value n bv)%Z.
  Proof.
    intros; auto.
  Qed.

  Lemma Z_to_two_compl_Sn :
    forall (n:nat) (b:bool) (z:Z),
      Z_to_two_compl (S n) (bit_value b + 2 * z) =
      Bcons b (S n) (Z_to_two_compl n z).
  Proof.
    destruct b; destruct z as [| p| p]; auto.
    destruct p as [p| p| ]; auto.
    destruct p as [p| p| ]; simpl; auto.
    intros; rewrite (Pos.succ_pred_double p); trivial.
  Qed.

  Lemma Z_to_binary_Sn_z :
    forall (n:nat) (z:Z),
      Z_to_binary (S n) z =
      Bcons (Z.odd z) n (Z_to_binary n (Z.div2 z)).
  Proof.
    intros; auto.
  Qed.

  Lemma Z_div2_value :
    forall z:Z,
      (z >= 0)%Z -> (bit_value (Z.odd z) + 2 * Z.div2 z)%Z = z.
  Proof.
    destruct z as [| p| p]; auto.
    destruct p; auto.
    intro H; elim H; trivial.
  Qed.

  Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Z.div2 z >= 0)%Z.
  Proof.
    destruct z as [| p| p].
    auto.

    destruct p; auto.
    simpl; intros; omega.

    intro H; elim H; trivial.
  Qed.

  Lemma Zdiv2_two_power_nat :
    forall (z:Z) (n:nat),
      (z >= 0)%Z ->
      (z < two_power_nat (S n))%Z -> (Z.div2 z < two_power_nat n)%Z.
  Proof.
    intros.
    enough (2 * Z.div2 z < 2 * two_power_nat n)%Z by omega.
    rewrite <- two_power_nat_S.
    destruct (Zeven.Zeven_odd_dec z) as [Heven|Hodd]; intros.
    rewrite <- Zeven.Zeven_div2; auto.
    generalize (Zeven.Zodd_div2 z Hodd); omega.
  Qed.

  Lemma Z_to_two_compl_Sn_z :
    forall (n:nat) (z:Z),
      Z_to_two_compl (S n) z =
      Bcons (Z.odd z) (S n) (Z_to_two_compl n (Zmod2 z)).
  Proof.
    intros; auto.
  Qed.

  Lemma Zeven_bit_value :
    forall z:Z, Zeven.Zeven z -> bit_value (Z.odd z) = 0%Z.
  Proof.
    destruct z; unfold bit_value; auto.
    destruct p; tauto || (intro H; elim H).
    destruct p; tauto || (intro H; elim H).
  Qed.

  Lemma Zodd_bit_value :
    forall z:Z, Zeven.Zodd z -> bit_value (Z.odd z) = 1%Z.
  Proof.
    destruct z; unfold bit_value; auto.
    intros; elim H.
    destruct p; tauto || (intros; elim H).
    destruct p; tauto || (intros; elim H).
  Qed.

  Lemma Zge_minus_two_power_nat_S :
    forall (n:nat) (z:Z),
      (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
  Proof.
    intros n z; rewrite (two_power_nat_S n).
    generalize (Zmod2_twice z).
    destruct (Zeven.Zeven_odd_dec z) as [H| H].
    rewrite (Zeven_bit_value z H); intros; omega.

    rewrite (Zodd_bit_value z H); intros; omega.
  Qed.

  Lemma Zlt_two_power_nat_S :
    forall (n:nat) (z:Z),
      (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
  Proof.
    intros n z; rewrite (two_power_nat_S n).
    generalize (Zmod2_twice z).
    destruct (Zeven.Zeven_odd_dec z) as [H| H].
    rewrite (Zeven_bit_value z H); intros; omega.

    rewrite (Zodd_bit_value z H); intros; omega.
  Qed.

End Z_BRIC_A_BRAC.

Section COHERENT_VALUE.

(** We check that the functions are reciprocal on the definition interval.
    This uses earlier library lemmas.
*)

  Lemma binary_to_Z_to_binary :
    forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv.
  Proof.
    induction bv as [| a n bv IHbv].
    auto.

    rewrite binary_value_Sn.
    rewrite Z_to_binary_Sn.
    rewrite IHbv; trivial.

    apply binary_value_pos.
  Qed.

  Lemma two_compl_to_Z_to_two_compl :
    forall (n:nat) (bv:Bvector n) (b:bool),
      Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
  Proof.
    induction bv as [| a n bv IHbv]; intro b.
    destruct b; auto.

    rewrite two_compl_value_Sn.
    rewrite Z_to_two_compl_Sn.
    rewrite IHbv; trivial.
  Qed.

  Lemma Z_to_binary_to_Z :
    forall (n:nat) (z:Z),
      (z >= 0)%Z ->
      (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
  Proof.
    induction n as [| n IHn].
    unfold two_power_nat, shift_nat; simpl; intros; omega.

    intros; rewrite Z_to_binary_Sn_z.
    rewrite binary_value_Sn.
    rewrite IHn.
    apply Z_div2_value; auto.

    apply Pdiv2; trivial.

    apply Zdiv2_two_power_nat; trivial.
  Qed.

  Lemma Z_to_two_compl_to_Z :
    forall (n:nat) (z:Z),
      (z >= - two_power_nat n)%Z ->
      (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
  Proof.
    induction n as [| n IHn].
    unfold two_power_nat, shift_nat; simpl; intros.
    assert (z = (-1)%Z \/ z = 0%Z). omega.
    intuition; subst z; trivial.

    intros; rewrite Z_to_two_compl_Sn_z.
    rewrite two_compl_value_Sn.
    rewrite IHn.
    generalize (Zmod2_twice z); omega.

    apply Zge_minus_two_power_nat_S; auto.

    apply Zlt_two_power_nat_S; auto.
  Qed.

End COHERENT_VALUE.