Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import List.
Require Import Bedrock.Word
        Coq.ZArith.ZArith
        Coq.micromega.Psatz.

Require Import NArith NArithRing.
Local Open Scope N_scope.

Lemma natToWordToN : (* FIXME this is a simplified copy of the same lemma in Bedrock.IL *)
  forall n m,
    (N_of_nat m < Npow2 n)%N ->
    wordToN (natToWord n m) = N_of_nat m.
  intros; rewrite wordToN_nat, wordToNat_natToWord_idempotent by assumption.
  reflexivity.
Qed.

Lemma wordToN_combine:
  forall sz1 sz2 (w1: word sz1) (w2: word sz2), wordToN (combine w1 w2) = wordToN w1 + Npow2 sz1 * wordToN w2.
Proof.
  induction w1; simpl; intros.
  - destruct (wordToN w2); reflexivity.
  - rewrite IHw1; destruct b, (wordToN w1), (Npow2 n), (wordToN w2); reflexivity.
Qed.

Lemma Npow2_gt_zero:
  forall sz : nat, 0 < Npow2 sz.
Proof.
  induction sz; try reflexivity.
  apply N.mul_pos_pos; auto || reflexivity.
Qed.

Lemma Npow2_ge_one:
  forall sz : nat, 1 <= Npow2 sz.
Proof.
  intros.
  apply N.lt_succ_r.
  rewrite <- N.add_1_l.
  apply N.lt_sub_lt_add_l.
  apply Npow2_gt_zero.
Qed.

Lemma wordToN_wzero {sz} :
  wordToN (wzero sz) = 0%N.
Proof.
  intros; unfold wzero; rewrite natToWordToN.
  - reflexivity.
  - apply Npow2_gt_zero.
Qed.

Lemma wordToN_extend sz sz' :
  forall (w: word sz), wordToN (combine w (wzero sz')) = wordToN w.
Proof.
  intros; rewrite (wordToN_combine sz sz').
  rewrite wordToN_wzero; ring.
Qed.

Lemma N_le_succ_plus_1 : forall n m : N, (n + 1 <= m)%N <-> (n < m)%N.
Proof.
  intros; rewrite N.add_1_r.
  apply N.le_succ_l.
Qed.

Lemma N_lt_double_lt:
  forall p p' : N,
    (p < p')%N ->
    (2 * p < 2 * p')%N.
Proof.
  intros; apply N.mul_lt_mono_pos_l; eauto; reflexivity.
Qed.

Lemma N_le_double:
  forall p : N,
    (p <= 2 * p)%N.
Proof.
  intros; replace (2 * p)%N with (p + p)%N by ring.
  replace p with (0 + p)%N at 1 by ring.
  rewrite <- N.add_le_mono_r.
  apply N.le_0_l.
Qed.

Lemma N_lt_double:
  forall p : N,
    (0 < p)%N ->
    (p < 2 * p)%N.
Proof.
  intros; replace (2 * p)%N with (p + p)%N by ring.
  replace p with (0 + p)%N at 1 by ring.
  rewrite <- N.add_lt_mono_r.
  assumption.
Qed.

Lemma wordToN_bound {size} (w: Word.word size):
  (wordToN w < Npow2 size)%N.
Proof.
  Opaque N.mul.
  induction size.
  - rewrite (shatter_word_0 w); reflexivity.
  - destruct (shatter_word_S w) as (b & [ w' ? ]); subst.
    destruct b; simpl.
    rewrite <- N.add_1_r.
    auto using N.double_above.
    auto using N_lt_double_lt, N.double_above.
Qed.

Lemma NToWord_wordToN {sz} :
  forall (w: word sz), NToWord _ (wordToN w) = w.
Proof.
  intros; rewrite NToWord_nat, wordToN_nat, Nat2N.id, natToWord_wordToNat;
    reflexivity.
Qed.

Lemma wordToN_wones :
  forall sz, wordToN (wones sz) = Npow2 sz - 1.
Proof.
  induction sz.
  - reflexivity.
  - simpl; rewrite IHsz.
    pose proof (Npow2_ge_one sz); lia.
Qed.

Lemma wordToN_wnot:
  forall (n : nat) (w : word n), wordToN (wnot w) = Npow2 n - 1 - wordToN w.
Proof.
  destruct n; intros.
  - shatter_word w; reflexivity.
  - destruct (shatter_word_S w) as (b & [ w' ? ]); subst.
    revert b; induction w'.
    + destruct b; reflexivity.
    + intros; simpl in *;
        rewrite IHw';
        destruct b0; simpl; [ lia | ];
          destruct b; pose proof (wordToN_bound w'); lia.
Qed.

Lemma wplus_wnot_1:
  forall (n : nat) (w : word n), wordToN w + (Npow2 n - 1 - wordToN w) = Npow2 n - 1.
Proof.
  intros; pose proof (wordToN_bound (size := n) w); lia.
Qed.

Lemma wplus_wnot {sz}:
  forall w, wplus w (wnot w) = wones sz.
Proof.
  unfold wplus, wordBin; intros.
  rewrite wordToN_wnot, wplus_wnot_1, <- wordToN_wones, NToWord_wordToN;
    reflexivity.
Qed.

Definition W16 := Word.word 16.
Definition lo8 (w: W16) : word 8 := @split1 8 8 w.
Definition hi8 (w: W16) : word 8 := @split2 8 8 w.

Lemma wnot_involutive {sz} :
  forall (w: word sz),
    wnot (wnot w) = w.
Proof.
  induction w.
  - reflexivity.
  - simpl.
    rewrite IHw, Bool.negb_involutive; reflexivity.
Qed.

Lemma wnot_inj {sz} :
  forall w1 w2: word sz,
    wnot w1 = wnot w2 ->
    w1 = w2.
Proof.
  intros w1 w2 H.
  apply (f_equal (@wnot _)) in H.
  rewrite !wnot_involutive in H; assumption.
Qed.

Lemma wmsb_wzero {sz} :
  wmsb (wzero (S sz)) true = false.
Proof.
  induction sz; eauto.
Qed.

Lemma wmsb_wones {sz} :
  wmsb (wones sz) true = true.
Proof.
  induction sz; eauto.
Qed.

Fixpoint waddmsb {sz} (w: word sz) msb : word (S sz) :=
  match w with
  | WO => WS msb WO
  | @WS b sz w' => WS b (waddmsb w' msb)
  end.

Lemma wmsb_waddmsb:
  forall (sz : nat) (w : word sz) (b b' : bool), wmsb (waddmsb w b) b' = b.
Proof.
  induction w; simpl; intros; try rewrite IHw; reflexivity.
Qed.

Lemma wnot_waddmsb {sz} :
  forall b (w: word sz), (wnot (waddmsb w b)) = waddmsb (wnot w) (negb b).
Proof.
  induction w; simpl; congruence.
Qed.

Lemma wordToN_waddmsb:
  forall b (sz : nat) (w : word sz), wordToN (waddmsb w b) = wordToN w + (if b then Npow2 sz else 0).
Proof.
  induction w;
    repeat match goal with
           | _ => ring
           | _ => reflexivity
           | _ => progress simpl
           | _ => rewrite <- !N.add_1_r
           | [ H: bool |- _ ] => destruct H
           | [ H: _ |- _ ] => rewrite H
           end.
Qed.

Lemma wnot_wones_wzero :
  forall sz, wnot (wones sz) = wzero sz.
Proof.
  induction sz; simpl; try rewrite IHsz; reflexivity.
Qed.

Lemma wnot_wzero_wones :
  forall sz, wnot (wzero sz) = wones sz.
Proof.
  intros; rewrite <- wnot_wones_wzero.
  apply wnot_involutive.
Qed.

Lemma wmsb_wnot':
  forall (n : nat) (w : word n) (b : bool), wmsb (wnot w) (negb b) = negb (wmsb w b).
Proof.
  induction w; simpl; intros.
  * reflexivity.
  * rewrite IHw; reflexivity.
Qed.

Lemma wmsb_wnot:
  forall (n : nat) (w : word (S n)), wmsb (wnot w) true = negb (wmsb w true).
Proof.
  intros; destruct (shatter_word_S w) as (b & [ w' ? ]); subst.
  simpl; apply wmsb_wnot'.
Qed.

Lemma wordToN_NToWord_idempotent:
  forall (sz : nat) (p : N),
    p < Npow2 sz ->
    wordToN (NToWord sz p) = p.
Proof.
  intros; rewrite NToWord_nat.
  rewrite natToWordToN; rewrite N2Nat.id; auto.
Qed.

Lemma wordToN_posToWord :
  forall (sz : nat) (p : positive),
    Npos p < Npow2 sz ->
    wordToN (posToWord sz p) = Npos p.
Proof.
  intros; rewrite <- (wordToN_NToWord_idempotent sz (Npos p)); auto.
Qed.

Require Import ZArith ZArithRing.
Local Open Scope Z_scope.

Fixpoint count from n :=
  match n with
  | O => nil
  | S x => from :: (count (from + 1) x)
  end.

Infix "+^+" := combine (at level 50).

Definition OneCToZ {sz} (w : word sz) : Z :=
  if wmsb w true then
    (* Negative *)
    match wordToN (wnot w) with
      | N0 => 0%Z
      | Npos x => Zneg x
    end
  else
    (* Positive *)
    match wordToN w with
      | N0 => 0%Z
      | Npos x => Zpos x
    end.

Require Import Program.

Definition normalizeZ p z :=
  let offset := Z.of_N (Npow2 p - 1) in
  let modulus := Z.of_N (Npow2 (S p) - 1) in
  (Z.modulo (z + offset) modulus) - offset.

(*Compute (List.map (normalizeZ 3) (count (-40) 40)). *)

Definition ZToOneC {sz} (z: Z) : word sz :=
  match sz with
  | O => WO
  | S sz' => match (normalizeZ sz' z) with
            | Z0 => wones (S sz')
            | Zpos x => waddmsb (posToWord sz' x) false
            | Zneg x => wnot (waddmsb (posToWord sz' x) false)
            end
  end.

(* Compute (@ZToOneC 4 8). *)

Lemma gt_minus_one_ge_zero :
  forall z, -1 < z <-> 0 <= z.
Proof.
  intros; omega.
Qed.

Hint Rewrite Z.lt_sub_lt_add_l : normalizeZ.
Hint Rewrite Z.lt_sub_lt_add_r : normalizeZ.
Hint Rewrite <- Z.lt_add_lt_sub_l : normalizeZ.
Hint Rewrite <- Z.lt_add_lt_sub_r : normalizeZ.
Hint Rewrite @gt_minus_one_ge_zero : normalizeZ.

Require Import Coq.micromega.Psatz.

Notation OneC_InRange p z := ((- Z.of_N (Npow2 p)) < z < Z.of_N (Npow2 p)).

Lemma normalizeZ_range :
  forall p z, OneC_InRange p (normalizeZ p z).
Proof.
  split;
    repeat match goal with
           | _ => progress intros
           | _ => progress unfold normalizeZ
           | _ => progress ring_simplify
           | _ => progress autorewrite with normalizeZ
           | _ => progress rewrite ?N2Z.inj_mul, ?N2Z.inj_sub by eauto using Npow2_ge_one
           | _ => simpl (Z.of_N _)
           end.
  - apply Z_mod_lt.
    pose proof (Npow2_ge_one p); lia.
  - rewrite Z.lt_add_lt_sub_r.
    apply Z_mod_lt.
    pose proof (Npow2_ge_one p); lia.
Qed.

Lemma normalizeZ_rangeN :
  forall p z,
    match normalizeZ p z with
    | Z0 => True
    | Zpos x => (Npos x < Npow2 p)%N
    | Zneg x => (Npos x < Npow2 p)%N
    end.
Proof.
  intros; destruct (normalizeZ_range p z).
  destruct (normalizeZ _ _); lia.
Qed.

Lemma weqb_correct {sz} :
  forall w1 w2: word sz,
    Word.weqb w1 w2 = false -> w1 <> w2.
Proof.
  red; intros ??? Heq.
  rewrite <- weqb_true_iff in Heq.
  congruence.
Qed.

Definition weqdec {sz} :
  forall w1 w2: word sz,
    { w1 = w2 } + { w1 <> w2 }.
Proof.
  intros; destruct (Word.weqb w1 w2) eqn:?.
  apply weqb_sound in Heqb; auto.
  apply weqb_correct in Heqb; auto.
Defined.

Definition OneC_plus {sz} (w1 w2: word sz) :=
  if weqdec w1 (wzero sz) then
    w2
  else if weqdec w2 (wzero sz) then
         w1
       else
         @ZToOneC sz (OneCToZ w1 + OneCToZ w2).

Infix "^1+" := (OneC_plus) (at level 50, left associativity) : oneC_scope.
Local Open Scope oneC_scope.

Ltac destruct_eqdec :=
  repeat match goal with
         | [  |- context[if (weqdec ?a (wzero ?sz)) then _ else _] ] =>
           lazymatch a with
           | context[if _ then _ else _] => fail
           (* | context[Z.add] => fail *)
           | _ => destruct (weqdec a (wzero sz)); subst
           end
         end.

Lemma OneC_plus_comm {sz}:
  forall (w1 w2: word sz),
    w1 ^1+ w2 = w2 ^1+ w1.
Proof.
  unfold OneC_plus; intros; rewrite Z.add_comm.
  destruct_eqdec; congruence.
Qed.

Lemma OneCToZ_wzero:
  forall sz : nat, OneCToZ (wzero sz) = 0.
Proof.
  unfold OneCToZ.
  destruct sz; [reflexivity|].
  rewrite wmsb_wzero, wordToN_wzero.
  reflexivity.
Qed.

Lemma OneCToZ_wones:
  forall sz : nat, OneCToZ (wones sz) = 0.
Proof.
  unfold OneCToZ.
  destruct sz; [reflexivity|].
  rewrite wmsb_wones, wnot_wones_wzero, wordToN_wzero.
  reflexivity.
Qed.

Lemma OneCToZ_ZToOneC {sz}:
  forall z, OneCToZ (@ZToOneC sz z) = match sz with
                                 | O => 0
                                 | S sz => normalizeZ sz z
                                 end.
Proof.
  unfold ZToOneC; destruct sz; intros.
  - reflexivity.
  - pose proof (normalizeZ_rangeN sz z);
      destruct (normalizeZ _ _) eqn:? ;
      repeat match goal with
             | _ => solve [auto]
             | _ => solve [apply OneCToZ_wones]
             | _ => progress simpl
             | _ => progress unfold OneCToZ
             | _ => progress rewrite ?wmsb_waddmsb, ?wnot_waddmsb, ?wordToN_waddmsb
             | _ => progress rewrite ?N.add_0_r, ?wordToN_posToWord, ?wnot_involutive
             end.
Qed.

Lemma normalizeZ_add_1 :
  forall z z1 z2,
    (z1 + ((z2 + (z - 1)) mod (2 * z - 1) - (z - 1)) + (z - 1)) mod (2 * z - 1) =
    (z1 + z2 + (z - 1)) mod (2 * z - 1).
Proof.
  intros.
  replace (z1 + ((z2 + (z - 1)) mod (2 * z - 1) - (z - 1)) + (z - 1))
  with (z1 + (z2 + (z - 1)) mod (2 * z - 1)) by ring.
  rewrite Zplus_mod, Zmod_mod, <- Zplus_mod.
  f_equal; ring.
Qed.

Lemma normalizeZ_add_normalizeZ_r {sz} :
  forall z1 z2,
    normalizeZ sz (z1 + (normalizeZ sz z2)) =
    normalizeZ sz (z1 + z2).
Proof.
  unfold normalizeZ; intros;
    repeat match goal with
           | _ => progress rewrite ?N2Z.inj_mul, ?N2Z.inj_sub by eauto using Npow2_ge_one
           | _ => progress (simpl (Z.of_N _); simpl (Npow2 _))
           | _ => set (Z.of_N _)
           end.
  f_equal; apply normalizeZ_add_1.
Qed.

Lemma normalizeZ_add_normalizeZ_l {sz} :
  forall z1 z2,
    normalizeZ sz ((normalizeZ sz z2) + z1) =
    normalizeZ sz (z1 + z2).
Proof.
  intros; rewrite Z.add_comm; apply normalizeZ_add_normalizeZ_r.
Qed.

Lemma wzero_S {sz} :
  wzero (S sz) = (wzero sz)~0.
Proof.
  rewrite <- natToWord_wordToNat at 1.
  rewrite <- natToWord_wordToNat.
  f_equal.
Qed.

Lemma wones_not_wzero {sz}:
  wones (S sz) <> wzero (S sz).
Proof.
  rewrite <- wnot_wones_wzero; discriminate.
Qed.

Lemma whd_waddmsb {sz}:
  forall b (w: word (S sz)),
    whd (waddmsb w b) = whd w.
Proof.
  intros;
    destruct (shatter_word_S w) as (? & [ ? ? ]);
    subst; reflexivity.
Qed.

Fixpoint wcountones {sz} (w: word sz) : nat :=
  match w with
  | WO => 0
  | @WS x n w' => (if Bool.eqb x true then 1 else 0) + wcountones w'
  end%nat.

Lemma wcountones_wzero {sz} :
  wcountones (wzero sz) = 0%nat.
Proof.
  rewrite <- wzero'_def.
  induction sz; simpl; congruence.
Qed.

Lemma wcountones_waddmsb {sz} :
  forall (w: word sz) b,
    wcountones (waddmsb w b) =
    wcountones (WS b w).
Proof.
  induction w; simpl in *; intros.
  - reflexivity.
  - specialize (IHw b0).
    destruct b; destruct b0; simpl in *; rewrite IHw; reflexivity.
Qed.

Lemma wcountones_zero {sz} :
  forall w: word sz,
    wcountones w = 0%nat ->
    w = wzero _.
Proof.
  induction w.
  - reflexivity.
  - destruct b; simpl; intros; try discriminate.
    rewrite IHw by assumption.
    apply wzero_S.
Qed.

Lemma ZToOneC_nonzero {sz} :
  forall z: Z,
    ZToOneC z <> wzero (S (S sz)).
Proof.
  red; intros.
  unfold ZToOneC in *.
  pose proof (normalizeZ_rangeN (S sz) z);
    destruct (normalizeZ _ _) in *;
    match goal with
    | _ => eapply wones_not_wzero; eassumption
    | [ H: _ = wzero _ |- _ ] =>
      rewrite ?wnot_waddmsb in H;
        apply (f_equal (@wcountones _)) in H;
        rewrite wcountones_wzero, wcountones_waddmsb in H;
        simpl in H
    end.
  - apply wcountones_zero in H;
      apply (f_equal (@wordToN _)) in H;
      rewrite wordToN_posToWord, wordToN_wzero in H by assumption;
      discriminate.
  - discriminate.
Qed.

Lemma OneC_plus_assoc {sz}:
  forall (w1 w2 w3: word sz),
    w1 ^1+ (w2 ^1+ w3) = (w1 ^1+ w2) ^1+ w3.
Proof.
  unfold OneC_plus; destruct sz; intros.
  - setoid_rewrite shatter_word_0; reflexivity.
  - destruct_eqdec; try congruence;
      try match goal with
          | [ H: ZToOneC _ = (wzero _) |- _ ] =>
            destruct sz; [ | exfalso; eapply ZToOneC_nonzero; eassumption]
          end;
      change (wzero 1) with (WO~0) in *;
      repeat match goal with
             | [ w: word 1 |- _ ] => shatter_word w
             | [ b: bool |- _ ] => destruct b; try congruence
             end.

    rewrite !OneCToZ_ZToOneC; unfold ZToOneC.
    rewrite ?normalizeZ_add_normalizeZ_l, ?normalizeZ_add_normalizeZ_r.
    replace (OneCToZ w3 + (OneCToZ w1 + OneCToZ w2)) with (OneCToZ w1 + (OneCToZ w2 + OneCToZ w3)) by ring.
    reflexivity.
Qed.

Lemma OneCToZ_wnot_neg:
  forall (sz : nat) (w : word sz), OneCToZ (wnot w) = - OneCToZ w.
Proof.
  destruct w.
  + reflexivity.
  + unfold OneCToZ.
    rewrite wmsb_wnot.
    destruct (wmsb _ _);
      repeat match goal with
             | _ => reflexivity
             | _ => progress simpl
             | _ => progress rewrite ?Bool.negb_involutive, ?wnot_involutive
             | [  |- context[if ?t then ?a else ?b] ] =>
               destruct (if t then a else b)
             end.
Qed.

Lemma normalizeZ_zero:
  forall sz : nat, normalizeZ sz 0 = 0.
Proof.
  unfold normalizeZ; intros; simpl.
  rewrite Z.mod_small.
  - ring.
  - pose proof (Npow2_ge_one sz); lia.
Qed.

Lemma ZToOneC_zero:
  forall sz : nat, ZToOneC 0 = wones sz.
Proof.
  destruct sz.
  - reflexivity.
  - unfold ZToOneC.
    rewrite normalizeZ_zero; reflexivity.
Qed.

Lemma OneC_plus_wnot {sz}:
  forall w, w ^1+ (wnot w) = wones sz.
Proof.
  unfold OneC_plus; intros.
  rewrite OneCToZ_wnot_neg.
  replace (_ + _) with 0 by ring.
  destruct_eqdec; try congruence.
  - apply wnot_wzero_wones.
  - apply wnot_inj. rewrite wnot_wones_wzero; assumption.
  - apply ZToOneC_zero.
Qed.

Definition add_w16_into_checksum (w16: W16) (checksum: W16) :=
  checksum ^1+ w16.

Definition add_bytes_into_checksum (hi lo: word 8) (checksum: W16) :=
  add_w16_into_checksum (combine lo hi) checksum.

Fixpoint checksum bytes : W16 :=
  match bytes with
  | nil => wzero _
  | x :: nil => add_bytes_into_checksum x (wzero _) (wzero _)
  | x :: y :: t => add_bytes_into_checksum x y (checksum t)
  end.

Require Import AlignedByteString.

Fixpoint Vector_checksum {sz} (bytes: ByteBuffer.t sz) : W16 :=
  match bytes with
  | @Vector.nil _ => wzero _
  | @Vector.cons _ x _ (@Vector.nil _) => add_bytes_into_checksum x (wzero _) (wzero _)
  | @Vector.cons _ x _ (@Vector.cons _ y _ t) => add_bytes_into_checksum x y (Vector_checksum t)
  end.

Lemma Vector_checksum_eq_checksum'
  : forall (sz' sz : nat)
           (sz_lt : le sz sz')
           (bytes : ByteBuffer.t sz),
    Vector_checksum bytes = checksum (Vector.to_list bytes).
Proof.
  induction sz'; simpl; eauto.
  - intros; inversion sz_lt; subst.
    revert bytes; apply Vector.case0; reflexivity.
  - intros; inversion sz_lt; subst; eauto.
    revert IHsz'; pattern sz', bytes; apply Vector.caseS;
      simpl; intros.
    destruct t; simpl in *; eauto.
    rewrite IHsz'; eauto.
Qed.

Corollary Vector_checksum_eq_checksum {sz}
  : forall (bytes : ByteBuffer.t sz),
    Vector_checksum bytes = checksum (Vector.to_list bytes).
Proof.
  intros; eapply Vector_checksum_eq_checksum'; eauto.
Qed.

Corollary checksum_eq_Vector_checksum
  : forall (bytes : list (word 8)),
    checksum bytes = Vector_checksum (Vector.of_list bytes).
Proof.
  intros; rewrite Vector_checksum_eq_checksum, Vector.to_list_of_list_opp; reflexivity.
Qed.

Fixpoint make_pairs {A} (ls: list A) zero :=
  match ls with
  | nil => nil
  | x :: nil => [(x, zero)]
  | x :: y :: t => (x, y) :: (make_pairs t zero)
  end.

Definition checksum' byte_pairs : W16 :=
  fold_right (fun p chk => add_bytes_into_checksum (fst p) (snd p) chk) (wzero _) byte_pairs.

Lemma checksum_checksum' :
  forall bytes,
    checksum bytes = checksum' (make_pairs bytes (wzero _)).
Proof.
  fix IH 1.
  destruct bytes.
  - reflexivity.
  - destruct bytes.
    + reflexivity.
    + simpl; rewrite IH; reflexivity.
Qed.

Require Import Permutation.

Lemma add_bytes_into_checksum_swap:
  forall (chk : W16) (b11 b12 b21 b22 : word 8),
    add_bytes_into_checksum b22 b21 (add_bytes_into_checksum b12 b11 chk) =
    add_bytes_into_checksum b12 b11 (add_bytes_into_checksum b22 b21 chk).
Proof.
  unfold add_bytes_into_checksum, add_w16_into_checksum.
  intros; rewrite <- !OneC_plus_assoc.
  rewrite (OneC_plus_comm (combine b11 b12)).
  reflexivity.
Qed.

Lemma checksum'_permutation :
  forall bs1 bs2,
    Permutation bs1 bs2 ->
    checksum' bs1 = checksum' bs2.
Proof.
  induction 1.
  - reflexivity.
  - simpl; rewrite IHPermutation; reflexivity.
  - simpl. rewrite add_bytes_into_checksum_swap; reflexivity.
  - etransitivity; eauto.
Qed.

Fixpoint ByteBuffer_fold_left_pair {B} (f: Core.char -> Core.char -> B -> B) {sz: nat} n (v: ByteBuffer.t sz) (acc: B) (pad: Core.char) : B :=
  match n, v with
  | 0%nat, _ => acc
  | _, @Vector.nil _ => acc
  | 1%nat, @Vector.cons _ x _ _ => f x pad acc
  | _, @Vector.cons _ x _ (@Vector.nil _) => f x pad acc
  | S (S n'), @Vector.cons _ x _ (@Vector.cons _ y _ tl) => ByteBuffer_fold_left_pair f n' tl (f x y acc) pad
  end.

Definition ByteBuffer_fold_left16 {B} (f: word 16 -> B -> B) {sz: nat} n (v: ByteBuffer.t sz) acc :=
  ByteBuffer_fold_left_pair (fun hi lo => f (combine lo hi)) n v acc (wzero _).

Definition checksum'' byte_pairs acc : W16 :=
  fold_left (fun chk p => add_bytes_into_checksum (fst p) (snd p) chk) byte_pairs acc.

Lemma checksum'_checksum'' :
  forall pairs, checksum' pairs = checksum'' pairs (wzero _).
Proof.
  unfold checksum', checksum''; intros.
  rewrite <- fold_left_rev_right, (checksum'_permutation _ _ (Permutation_rev _)).
  reflexivity.
Qed.

Fixpoint Vector_checksum_bound n {sz} (bytes :ByteBuffer.t sz) acc : W16 :=
  match n, bytes with
  | 0, _ => acc
  | _, Vector.nil => acc
  | S 0, Vector.cons x _ _ => add_bytes_into_checksum x (wzero _) acc
  | _, Vector.cons x _ Vector.nil => add_bytes_into_checksum x (wzero _) acc
  | S (S n'), Vector.cons x _ (Vector.cons y _ t) =>
    (Vector_checksum_bound n' t (add_bytes_into_checksum x y acc))
  end%nat.

Definition ByteBuffer_checksum_bound n {sz} (bytes : ByteBuffer.t sz) : W16 :=
  ByteBuffer_fold_left16 add_w16_into_checksum n bytes (wzero _).

Lemma ByteBuffer_checksum_bound_ok' :
  forall n {sz} (bytes :ByteBuffer.t sz) acc,
    Vector_checksum_bound n bytes acc =
    ByteBuffer_fold_left16 add_w16_into_checksum n bytes acc.
Proof.
  fix IH 3.
  destruct bytes as [ | hd sz [ | hd' sz' tl ] ]; intros; simpl.
  - destruct n as [ | [ | ] ]; reflexivity.
  - destruct n as [ | [ | ] ]; reflexivity.
  - destruct n as [ | [ | ] ]; simpl; try reflexivity.
    rewrite IH; reflexivity.
Qed.

Lemma ByteBuffer_checksum_bound_ok :
  forall n {sz} (bytes :ByteBuffer.t sz),
    Vector_checksum_bound n bytes (wzero _) = ByteBuffer_checksum_bound n bytes.
Proof.
  intros; apply ByteBuffer_checksum_bound_ok'.
Qed.

Definition ByteBuffer_checksum {sz} (bytes : ByteBuffer.t sz) : W16 :=
  ByteBuffer_checksum_bound sz bytes.

Lemma ByteBuffer_checksum_checksum'' :
  forall {sz} (bytes: ByteBuffer.t sz) acc,
    ByteBuffer_fold_left16 add_w16_into_checksum sz bytes acc =
    checksum'' (make_pairs (Vector.to_list bytes) (wzero _)) acc.
Proof.
  fix IH 2.
  destruct bytes as [ | hd sz [ | hd' sz' tl ] ]; intros; simpl.
  - reflexivity.
  - reflexivity.
  - unfold ByteBuffer_fold_left16 in *; simpl in *. rewrite IH. reflexivity.
Qed.

Lemma Vector_checksum_ByteBuffer_checksum :
  forall {sz} (bytes: ByteBuffer.t sz),
    Vector_checksum bytes = ByteBuffer_checksum bytes.
Proof.
  intros.
  rewrite Vector_checksum_eq_checksum, checksum_checksum'.
  unfold ByteBuffer_checksum, ByteBuffer_checksum_bound; rewrite ByteBuffer_checksum_checksum''.
  apply checksum'_checksum''.
Qed.

Lemma checksum'_app :
  forall bs1 bs2,
    checksum' (bs1 ++ bs2) = checksum' (bs2 ++ bs1).
Proof.
  intros; apply checksum'_permutation, Permutation_app_comm.
Qed.

Lemma make_pairs_app {A} :
  forall bs1,
    (exists x, length bs1 = 2 * x)%nat ->
    (forall bs2 z, @make_pairs A (bs1 ++ bs2) z = make_pairs bs1 z ++ make_pairs bs2 z).
Proof.
  fix IH 1.
  destruct bs1; simpl.
  - reflexivity.
  - destruct bs1; simpl; intros Hex *; destruct Hex as [x ?].
    + (* Absurd case *) omega.
    + f_equal; rewrite IH.
      * reflexivity.
      * exists (pred x); omega.
Qed.

Lemma checksum_split :
  forall bs1 bs2,
    (exists x, length bs1 = 2 * x)%nat ->
    checksum (bs1 ++ bs2) = checksum bs1 ^1+ checksum bs2.
Proof.
  fix IH 1.
  destruct bs1; intros.
  - reflexivity.
  - destruct bs1; destruct H; simpl in *.
    + omega.
    + rewrite IH.
      * unfold add_bytes_into_checksum, add_w16_into_checksum.
        rewrite <- !OneC_plus_assoc. f_equal.
        rewrite OneC_plus_comm. reflexivity.
      * exists (pred x). omega.
Qed.

Lemma checksum_app :
  forall bs1 bs2,
    (exists x, length bs1 = 2 * x)%nat ->
    (exists x, length bs2 = 2 * x)%nat ->
    checksum (bs1 ++ bs2) = checksum (bs2 ++ bs1).
Proof.
  intros; rewrite !checksum_checksum'.
  rewrite !make_pairs_app by assumption.
  apply checksum'_app.
Qed.

Lemma checksum_correct :
  forall bytes,
    let chk := checksum bytes in
    let neg := wnot chk in
    checksum ((hi8 neg) :: (lo8 neg) :: bytes) = wones _.
Proof.
  repeat match goal with
         | _ => progress intros
         | _ => progress unfold lo8, hi8, add_bytes_into_checksum
         | _ => progress (unfold checksum; fold checksum)
         | _ => rewrite combine_split
         | [ H := _ |- _ ] => unfold H in *; clear H
         | _ => eauto using OneC_plus_wnot
         end.
Qed.

Lemma normalizeZ_noop :
  forall p z, OneC_InRange p z -> normalizeZ p z = z.
Proof.
  intros * (? & ?).
  unfold normalizeZ; intros;
    repeat match goal with
           | _ => progress rewrite ?N2Z.inj_mul, ?N2Z.inj_sub by eauto using Npow2_ge_one
           | _ => progress (simpl (Z.of_N _); simpl (Npow2 _))
           end; set (Z.of_N _) in *.
  rewrite Z.mod_small by lia.
  ring.
Qed.

Lemma WS_match_eq_refl {sz sz'} :
  forall b (w: word sz) (w': word sz') (eql: sz = sz') (eqlS: S sz = S sz'),
    w = match eql in _ = y return (word y -> word sz) with
        | eq_refl => fun x: word sz => x
        end w' ->
    WS b w = match eqlS in _ = y return (word y -> word (S sz)) with
             | eq_refl => fun x: word (S sz) => x
             end (WS b w').
Proof.
  intros.
  destruct eql; subst.
  rewrite (UIP_nat _ _ eqlS eq_refl).
  reflexivity.
Qed.

(*(* 8.7 Definition *)
   Lemma wmsb_combine {sz} :
  forall (w : word (S sz)) b,
  exists w' : word sz,
    w = match eq_sym (Nat.add_1_r sz) in (_ = y) return (word y -> word (S sz)) with
        | eq_refl => fun w' => w'
        end (w' +^+ WS (wmsb w b) WO).
Proof.
  induction sz; intros;
    destruct (shatter_word_S w) as (b' & [ w' ? ]); subst.
  - exists WO; pose proof (shatter_word_0 w'); subst; simpl.
    rewrite (UIP_nat _ _ (Nat.add_1_r 0) eq_refl); reflexivity.
  - specialize (IHsz w' b'); destruct IHsz as (w'' & Heq).
    simpl.
    exists (WS b' w'').
    change (WS b' w'' +^+ WS (wmsb w' b') WO) with (WS b' (w'' +^+ WS (wmsb w' b') WO)).
    eapply WS_match_eq_refl.
    rewrite Heq at 1.
    reflexivity.
Qed. *)

(* 8.4 Definition *)
   Lemma wmsb_combine {sz} :
  forall (w : word (S sz)) b,
  exists w' : word sz,
    w = match eq_sym (Nat.add_1_r sz) in (_ = y) return (word y -> word (S sz)) with
        | eq_refl => fun w' => w'
        end (w' +^+ WS (wmsb w b) WO).
Proof.
  induction sz; intros;
    destruct (shatter_word_S w) as (b' & [ w' ? ]); subst.
  - exists WO; pose proof (shatter_word_0 w'); subst; simpl.
    rewrite (UIP_nat _ _ (Nat.add_1_r 0) eq_refl); reflexivity.
  - specialize (IHsz w' b'); destruct IHsz as (w'' & Heq).
    simpl.
    exists (WS b' w'').
    change (WS b' w'' +^+ WS (wmsb w' b') WO) with (WS b' (w'' +^+ WS (wmsb w' b') WO)).
    eapply WS_match_eq_refl.
    rewrite Heq at 1.
    reflexivity.
Qed.

Lemma normalizeZ_OneCToZ {sz} :
  forall w: word (S sz), normalizeZ sz (OneCToZ w) = (OneCToZ w).
Proof.
  intros.
  apply normalizeZ_noop.
  unfold OneCToZ.
  pose proof (Npow2_ge_one sz).
  (* 8.7 script:  *)
     destruct (wmsb _ _) eqn:Heqb; destruct (wordToN _) eqn:Heqn;
    repeat match goal with
           | _ => lia
           | [ H: wordToN (wnot ?w) = _, Heqb: wmsb ?w _ = _ |- _ ] =>
             apply (f_equal negb) in Heqb; rewrite <- (wmsb_wnot' (S sz) w true) in Heqb; simpl in Heqb
           | [ H: wmsb ?w ?b = _ |- _ ] =>
             let w' := fresh in
             let Heqw := fresh in
             destruct (wmsb_combine w b) as (w' & Heqw);
               rewrite Heqw in Heqn;
               rewrite <- (Nat.add_1_r sz) in *;
               simpl in Heqn;
               clear Heqw;
               rewrite wordToN_combine in Heqn;
               pose proof (wordToN_bound w');
               simpl in Heqn; rewrite Heqb in Heqn; simpl in Heqn
           end.
  (* 8.4 script *)
     (* destruct (wmsb _ _) eqn:Heqb; destruct (wordToN _) eqn:Heqn;
    repeat match goal with
           | _ => lia
           | [ H: wordToN (wnot ?w) = _, Heqb: wmsb ?w _ = _ |- _ ] =>
             apply (f_equal negb) in Heqb; rewrite <- (wmsb_wnot' (S sz) w true) in Heqb; simpl in Heqb
           | [ H: wmsb ?w ?b = _ |- _ ] =>
             let w' := fresh in
             let Heqw := fresh in
             destruct (wmsb_combine w b) as (w' & Heqw);
               rewrite Heqw in Heqn;
               rewrite <- (Nat.add_1_r sz) in *;
               simpl in Heqn;
               clear Heqw;
               rewrite wordToN_combine in Heqn;
               pose proof (wordToN_bound w');
               simpl in Heqn; rewrite Heqb in Heqn; simpl in Heqn
           end. *)
Qed.

Lemma NToWord_zero {sz} :
  NToWord sz 0 = wzero sz.
Proof.
  rewrite NToWord_nat; simpl; reflexivity.
Qed.

Lemma wordToN_wzero' {sz} :
  forall w: word sz,
    wordToN w = 0%N ->
    w = wzero _.
Proof.
  intros.
  apply (f_equal (@NToWord sz)) in H.
  rewrite NToWord_wordToN, NToWord_zero in H.
  assumption.
Qed.

Lemma wordToN_NToWord :
  forall sz w, exists k, (wordToN (NToWord sz w) = w - k * Npow2 sz /\ k * Npow2 sz <= w)%N.
Proof.
  intros.
  destruct (wordToNat_natToWord sz (N.to_nat w)) as [ w' (Heq & side_condition) ].
  exists (N.of_nat w').
  rewrite NToWord_nat.
  rewrite wordToN_nat.
  split.
  - apply N2Nat.inj.
    rewrite Nat2N.id, N2Nat.inj_sub, N2Nat.inj_mul, Nat2N.id, Npow2_nat.
    assumption.
  - unfold N.le. rewrite N2Nat.inj_compare.
    rewrite <- nat_compare_le.
    rewrite N2Nat.inj_mul, Nat2N.id, Npow2_nat.
    assumption.
Qed.

Lemma waddmsb_NToWord {sz} :
  forall n,
    (n < Npow2 sz)%N ->
    waddmsb (NToWord sz n) false = (NToWord (S sz) n).
Proof.
  intros.
  apply wordToN_inj.
  rewrite wordToN_waddmsb; ring_simplify.
  rewrite !wordToN_NToWord_idempotent; simpl; lia.
Qed.

Lemma wordToN_bound_wmsb_false:
  forall (sz : nat) (w : word (S sz)) b,
    wmsb w b = false ->
    (wordToN w < Npow2 sz)%N.
Proof.
  induction sz.
  - intros; shatter_word w; simpl in *; subst; reflexivity.
  - intros * Heq; destruct (shatter_word_S w) as (b' & [ w' ? ]); subst; simpl in *.
    specialize (IHsz w' b' Heq).
    destruct b'; lia.
Qed.

Lemma ZToOneC_OneCToZ:
  forall (sz : nat) (w : word sz),
    w <> wzero _ ->
    ZToOneC (OneCToZ w) = w.
Proof.
  unfold ZToOneC.
  destruct sz; intros.
  - rewrite shatter_word_0; reflexivity.
  - rewrite normalizeZ_OneCToZ.
    unfold OneCToZ.
    destruct (wmsb _ _) eqn:Heqb; destruct (wordToN _) eqn:Heqn.
    + apply wordToN_wzero' in Heqn.
      apply wnot_inj.
      rewrite wnot_wones_wzero.
      auto.
    + apply wnot_inj; rewrite wnot_involutive.
      change (posToWord sz p) with (NToWord sz (N.pos p)).
      rewrite <- Heqn, waddmsb_NToWord, NToWord_wordToN.
      * reflexivity.
      * eapply wordToN_bound_wmsb_false.
        rewrite wmsb_wnot, Heqb; reflexivity.
    + apply wordToN_wzero' in Heqn.
      congruence.
    + change (posToWord sz p) with (NToWord sz (N.pos p)).
      rewrite <- Heqn.
      rewrite waddmsb_NToWord, NToWord_wordToN.
      * reflexivity.
      * eapply wordToN_bound_wmsb_false; eassumption.
Qed.

Lemma OneC_plus_wones {sz} :
  forall w,
    w <> (wzero sz) ->
    OneC_plus (wones sz) w = w.
Proof.
  unfold OneC_plus; intros.
  pose proof (@wones_not_wzero sz).
  destruct (weqdec (wones _) _), (weqdec w (wzero sz));
    try congruence.
  rewrite OneCToZ_wones; simpl.
  rewrite ZToOneC_OneCToZ; auto.
Qed.

Lemma split1_wzero:
  forall sz sz' : nat, split1 sz sz' (wzero (sz + sz')) = wzero sz.
Proof.
  intros; rewrite <- !wzero'_def.
  induction sz.
  - reflexivity.
  - simpl; f_equal; congruence.
Qed.

Lemma split2_wzero:
  forall sz sz' : nat, split2 sz sz' (wzero (sz + sz')) = wzero sz'.
Proof.
  intros; rewrite <- !wzero'_def.
  induction sz.
  - reflexivity.
  - simpl; f_equal; congruence.
Qed.

Lemma wzero_combine {sz sz'} :
  forall (w0: word sz) (w1: word sz'),
    combine w0 w1 = wzero _ ->
    w0 = wzero _ /\ w1 = wzero _.
Proof.
  intros * H.
  pose proof (f_equal (@split1 sz sz') H).
  pose proof (f_equal (@split2 sz sz') H).
  rewrite split1_combine, split1_wzero in H0.
  rewrite split2_combine, split2_wzero in H1.
  intuition.
Qed.

Lemma OneC_plus_wones_wzero {sz} :
  wones sz ^1+ wzero sz = wones sz.
Proof.
  unfold OneC_plus.
  pose proof (@wones_not_wzero sz);
    repeat match goal with
           | [  |- context[weqdec ?a ?b] ] => destruct (weqdec a b)
           end; congruence.
Qed.

Lemma combine_inj {sz sz'}:
  forall w00 w01 w10 w11,
    @combine sz w01 sz' w00 = combine w11 w10 ->
    w00 = w10 /\ w01 = w11.
Proof.
  intros * Heq; split;
    [ apply (f_equal (@split2 sz sz')) in Heq
    | apply (f_equal (@split1 sz sz')) in Heq];
    rewrite ?split1_combine, ?split2_combine in *;
    assumption.
Qed.

Lemma add_bytes_into_checksum_inj_l:
  forall (y00 y01 y10 y11 : word 8) chk,
    (y00 <> wzero _ \/ y01 <> wzero _) ->
    (y10 <> wzero _ \/ y11 <> wzero _) ->
    add_bytes_into_checksum y00 y01 chk =
    add_bytes_into_checksum y10 y11 chk ->
    y00 = y10 /\ y01 = y11.
Proof.
  unfold add_bytes_into_checksum, add_w16_into_checksum; intros * nonz0 nonz1 H.
  apply (f_equal (fun x => (wnot chk) ^1+ x)) in H.
  rewrite !(OneC_plus_assoc (wnot chk)), !(OneC_plus_comm (wnot chk)), !OneC_plus_wnot in H.
  repeat lazymatch goal with
         | [ H: context[wones _ ^1+ ?w] |- _ ] =>
           let heq := fresh "heq" in
           let hneq := fresh "hneq" in
           destruct (weqdec w (wzero _)) as [ heq | hneq ];
             [ rewrite heq in H; setoid_rewrite OneC_plus_wones_wzero in H |
               setoid_rewrite (OneC_plus_wones w hneq) in H ]
         | [ H: _ +^+ _ = wzero _ |- _ ] => apply wzero_combine in H; destruct H; subst
         end;
    try solve [split; reflexivity];
    try solve [match goal with
               | [ H: _ \/ _ |- _ ] => destruct H; try congruence
               end];
  first [apply combine_inj; eassumption
        | solve [intuition] ].
Qed.

Lemma checksum'_somewhat_injective :
  forall x y0 y1 z,
    fst y0 <> wzero 8 \/ snd y0 <> wzero 8 ->
    fst y1 <> wzero 8 \/ snd y1 <> wzero 8 ->
    checksum' (x ++ y0 :: z) = checksum' (x ++ y1 :: z) ->
    y0 = y1.
Proof.
  intros * ? ? H.
  rewrite !(checksum'_app _ (_ :: _)), <- !app_comm_cons in H.
  simpl in H; apply add_bytes_into_checksum_inj_l in H; try assumption.
  destruct y0, y1, H; simpl in *; congruence.
Qed.

Lemma wplus_three {sz} :
  forall w1 w2 w3: word sz,
    w1 ^+ w2 ^+ w3 =
    NToWord sz (wordToN w1 + wordToN w2 + wordToN w3)%N.
Proof.
  intros.
  rewrite !wordToN_nat, !NToWord_nat, !N2Nat.inj_add, !Nat2N.id.
  repeat rewrite wplus_alt; unfold wplusN, wordBinN.
  repeat match goal with
         | [ H: _ = _ |- _ ] => rewrite H; clear H
         | [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
           destruct (wordToNat_natToWord sz w) as [? [? ?]]
         end.
  replace (wordToNat w1 + wordToNat w2 - x * pow2 sz + wordToNat w3)%nat
  with (wordToNat w1 + wordToNat w2 + wordToNat w3 - x * pow2 sz)%nat by omega.
  apply drop_sub; omega.
Qed.

Definition OneC_plus_wplus sz :=
  forall w1 w2: word sz,
    OneC_plus w1 w2 =
    w1 ^+ w2 ^+ split2 _ _ (zext w1 sz ^+ zext w2 sz).

Fixpoint EnumerateWords sz : list (word sz) :=
  match sz with
  | O => [WO]
  | S sz' =>
    let wds := EnumerateWords sz' in
    map (@WS true sz') wds ++ map (@WS false sz') wds
  end.

Lemma Enumerate_exhaustive {sz} :
  forall w: word sz, In w (EnumerateWords sz).
Proof.
  induction w.
  - simpl; tauto.
  - simpl; rewrite in_app_iff.
    destruct b; [left|right];
      rewrite in_map_iff;
      exists w; tauto.
Qed.

Lemma brute_force_works {sz} :
  forall (P: word sz -> bool),
    (forallb P (EnumerateWords sz) = true) ->
    (forall w, P w = true).
Proof.
  intros * H w.
  rewrite forallb_forall in H.
  pose proof (@Enumerate_exhaustive sz).
  eauto.
Qed.

Lemma brute_force_works' {sz} :
  forall (P: word sz -> Prop)
    (P': word sz -> bool),
    (forall w, P' w = true -> P w) ->
    (forallb P' (EnumerateWords sz) = true) ->
    (forall w, P w).
Proof.
  intros * correctB forallB w.
  apply correctB; revert w.
  apply brute_force_works; assumption.
Qed.

Ltac OneC_plus_wplus_t :=
  red; intros; rewrite <- weqb_true_iff;
  repeat lazymatch goal with
         | [ w: word _ |- _ ] => revert w; apply brute_force_works
         end.

(*Lemma brute_force8 :
  OneC_plus_wplus 8.
Proof.
  OneC_plus_wplus_t.
  Time vm_compute.
  reflexivity.
Time Qed. *)


Require Import sf_spec.
Require Import RelDec.
Require Import List.
Require Import Sorting.
Require Import Orders.
Require Import Compare_dec.
Require Import Coq.Numbers.BinNums.
Require Import Coq.NArith.BinNat.
Import ListNotations.

Section candidate.

Local Open Scope N_scope.

Variable candidate : Set.
Variable reldec_candidate : RelDec (@eq candidate).

Definition rankSelection := rankSelection candidate.
Definition ballot := ballot candidate.

(** A record of an election will be a list of the candidates that are eliminated
in each step *)
Definition record := list (list candidate).

(** a ballot
shall be deemed "exhausted," and not counted in further stages of the
tabulation, if all of the choices have been eliminated or there are no
more choices indicated on the ballot. If a ranked-choice ballot gives
equal rank to two or more candidates, the ballot shall be declared
exhausted when such multiple rankings are reached. *)

Definition eliminated (rec : record) (cand : candidate) : bool :=
  existsb (existsb (eq_dec cand)) rec.

Definition no_viable_candidates_selection (rec : record) (sel : rankSelection) : bool :=
  forallb (eliminated rec) sel.

Definition no_viable_candidates (rec : record) (bal : ballot) : bool :=
  forallb (no_viable_candidates_selection rec) bal.

Fixpoint next_ranking (rec : record) (bal : ballot) : option (candidate * ballot) :=
match bal with
| [] :: t => next_ranking rec t
| (h :: l) :: t => if (forallb (eq_dec h) l) then
                     if (eliminated rec h) then next_ranking rec t else Some (h, bal)
                   else  None
| [] => None
end.

Fixpoint drop_none {A} (l : list (option A)) :=
match l with
| None :: t => drop_none t
| Some x :: t => x :: drop_none t
| [] => []
end.
Locate "+".
Fixpoint increment (r : list (candidate * N)) (c : candidate) :=
match r with
| (c1, n) :: t => if (eq_dec c1 c) then (c1, (n + 1)) :: t else (c1, n) :: increment t c
| nil => [(c, 1)]
end.

Fixpoint tabulate'' (rs : list (option candidate)) lc: list (candidate * N) :=
match rs with
| (Some h) :: t => tabulate'' t (increment lc h)
| None :: t => tabulate'' t lc
| nil => lc
end.

Definition tabulate' (rs : list (option candidate)) :=
tabulate'' rs nil.

Definition cnle (a b : (candidate * N)) : bool :=
match a, b with
(_, n1), (_, n2) => N.leb n1 n2
end.

Fixpoint insert {A} (cmp : A -> A -> bool) (i : A) (l : list A) :=
match l with
| h :: t => if (cmp i h) then i :: l else h :: (insert cmp i t)
| _ => [i]
end.

Fixpoint insertionsort' {A} (cmp : A -> A -> bool) (l : list A) (srtd : list A) :=
match l with
| h :: t => insertionsort' cmp t (insert cmp h srtd)
| [] => srtd
end.

Definition insertionsort {A} (cmp : A-> A -> bool) (l : list A) := insertionsort' cmp l nil.

Definition election := list ballot.

(** Here we count the number of votes for each candidate, returning a sorted
    list of (candidate, number of votes). It also returns an election, where any
    exhausted ballots are removed. *)
Fixpoint option_split {A B : Type} (l : list (option (A * B))) :=
match l with
| nil => (nil, nil)
| (Some (a, b)) :: t => let (l1, l2) := option_split t in ((Some a :: l1), (Some b :: l2))
| None :: t => let (l1, l2) := option_split t in ((None :: l1), ( None :: l2))
end.

Definition tabulate (rec : record) (elect : election) : ((list (candidate * N) * election)) :=
let get_candidates := (map (next_ranking rec) elect) in
let (next_ranks, next_election) := option_split (get_candidates) in
let counts := tabulate' next_ranks in
let sorted_ranks := insertionsort cnle counts in
(sorted_ranks, drop_none next_election).

Definition gtb_N (a b : N) : bool:=
negb (N.leb a b).

Require Import Omega.

Lemma gtb_nat_gt : forall a b,
gtb_N a b = true <-> a > b.
unfold gtb_N in *.
intros.
destruct ( a <=? b) eqn:?; intuition; try discriminate.
 - rewrite N.leb_le in Heqb0. exfalso. apply N.gt_lt in H.
   rewrite N.lt_eq_cases in Heqb0.
   destruct Heqb0. apply N.lt_asymm in H. auto. subst.
   apply N.lt_irrefl in H. auto.
 - rewrite N.leb_gt in Heqb0. clear H. apply N.gt_lt_iff. auto.
Qed.

Definition get_bottom_votes (votes : list (candidate * N)) :=
match votes with
| (c, v) :: t => map (@fst _ _) (filter (fun (x : candidate * N) => let (_, v') := x in
                                  N.eqb v v') votes)
| nil => nil
end.

Variable break_tie : list candidate -> option candidate.

(* This expects a list of candidates sorted ascending in number of votes *)
Fixpoint find_eliminated' (eliminated : list candidate) (votes : list (candidate * N)) (sum : N) :=
  match votes with
  | (cand, count) :: t =>
    match t with
    |  (cand2, count2) :: _ =>
       let newsum := sum + count in
       if (N.ltb (newsum) count2) then
         find_eliminated' (cand :: eliminated)
                          t sum
       else
         match eliminated with
         | nil => match break_tie (get_bottom_votes votes) with
                  | Some l => [l]
                  | None => nil
                  end
         | _ => eliminated
         end
    | _ => eliminated
    end
  | _ => eliminated
  end.

Definition find_eliminated votes :=
  find_eliminated' [] votes 0.

Definition find_eliminated_noopt votes :=
  match break_tie (get_bottom_votes votes) with
    | Some c => Some [c]
    | None => None
  end.

Fixpoint last_item votes : option (candidate * N) :=
match votes with
| h :: [] => Some h
| [] => None
| h :: t => last_item t
end.

Fixpoint run_election' (elect : election) (rec : record) (fuel : nat) :  (option candidate * record) :=
match fuel with
| S n' => let (ranks, elect') := (tabulate rec elect) in
          let win_threshhold := N.of_nat (length elect')  in
          (* here we use elect' because exhausted ballots have been removed *)
          match last_item ranks with
          | Some (cand1, cand1_votes)  =>
            if (gtb_N (cand1_votes * 2) (win_threshhold)) then
              (Some cand1, rec)
            else
              match (find_eliminated_noopt ranks) with
              | Some el =>
                run_election' elect(*' hopefully just an optimization...*)
                              (el :: rec) n'
              | None => (None, rec)
              end
          | None => (None, rec)
          end
| _ => (None, rec)
end.

Check filter.

Definition find_0s (all_candidates : list candidate) (el : election) :=
let get_candidates := (map (next_ranking nil) el) in
let (next_ranks, _) := option_split (get_candidates) in
let initial := map (fun x => (x, 0)) all_candidates in
let counts := tabulate'' next_ranks initial in
map (@fst _ _) (filter (fun (x : candidate * N) => let (_, ct) := x in N.eqb ct 0) counts).

Definition run_election elect all_candidates :=
let initial_selected := drop_none (fst (option_split (map (next_ranking nil) elect))) in
run_election' elect ([find_0s all_candidates elect]) (length elect).

End candidate.

Global Instance RelDec_eq : RelDec (@eq nat) :=
{ rel_dec := EqNat.beq_nat }.

Global Instance RelDec_lt : RelDec lt :=
{ rel_dec := NPeano.ltb }.

Global Instance RelDec_le : RelDec le :=
{ rel_dec := NPeano.leb }.

Global Instance RelDec_gt : RelDec gt :=
{ rel_dec := fun x y => NPeano.ltb y x }.

Global Instance RelDec_ge : RelDec ge :=
{ rel_dec := fun x y => NPeano.leb y x }.

Definition nat_tabulate := tabulate nat _.

Definition ballot1 : (ballot nat) :=
[[3]; [2]; [1]; [0]].

Definition ballot2 : (ballot nat) :=
[[2]; [1]; [3]; [0]].

Definition ballot3 : (ballot nat) := ballot1.

Definition ballot4 :=
[[0]; [1]].

Fixpoint repeat_append {A : Type} (l : list A) (n : nat) : list A :=
match n with
| O => nil
| S n' => l ++ (repeat_append l n')
end.

Definition election1 :=
[ballot1;
 ballot2;
 ballot3;
 ballot4].

Definition election2 := repeat_append election1 1000.

Compute (nat_tabulate nil (election1)).

Definition tiebreak (l : list nat) :=
match l with
| h :: t => Some h
| _ => None
end.


(** * Lista zadań nr 8 *)
(** autorstwa Wojciecha Kołowskiego *)
(** zadania punktowane za 0p nie będą sprawdzane *)

(** **** Zadanie 1 - 4p *)

(*
    Zdefiniuj typ potencjalnie nieskończonych drzew binarnych trzymających
    wartości typu A w węzłach, jego relację bipodobieństwa, predykaty
    "skończony" i "nieskończony" oraz funkcję mirror, która zwraca
    lustrzane odbicie drzewa. Udowodnij, że bipodobieństwo jest relacją
    równoważności i że funkcja mirror jest inwolucją (tzn. mirror (mirror t)
    jest bipodobne do t), która zachowuje właściwości bycia drzewem
    skończonym/nieskończonym. Pokaż, że drzewo nie może być jednocześnie
    skończone i nieskończone.
*)

CoInductive LTree (A : Type) : Type :=
{
  unnode : option (LTree A * A * LTree A);
}.

Definition LL {A : Type} (t : LTree A) :=
  match t with
  | {| unnode := a |} => {| unnode := a |}
  end.

Lemma LLid : forall (A : Type) (t : LTree A), t = LL t.
Proof.
  intros. unfold LL. destruct t. reflexivity.
  Qed.

Lemma ltree : forall (A : Type) (t : LTree A), exists r, t = {| unnode := r |}.
Proof.
  intros.
  case t as [ t' ]. induction t'; eexists; eauto.
  Qed.

CoInductive bisym {A : Type} (t1 t2 : LTree A) : Prop :=
| bileaf : unnode A t1 = None /\ unnode A t2 = None -> bisym t1 t2
| binode : forall t1l v1 t1r t2l v2 t2r,
    unnode A t1 = Some (t1l, v1, t1r) ->
    unnode A t2 = Some (t2l, v2, t2r) ->
    v1 = v2 ->
    bisym t1l t2l ->
    bisym t1r t2r ->
    bisym t1 t2
.

Definition leaf {A : Type} : LTree A := {| unnode := None |}.

Definition node {A : Type} l v r : LTree A := {| unnode := Some (l, v, r) |}.

Inductive Finite {A : Type} (t : LTree A) : Prop :=
| finleaf : unnode A t = None -> Finite t
| finnode : forall l v r, unnode A t = Some (l,v,r) -> Finite l -> Finite r -> Finite t
.

CoInductive Infinite {A : Type} (t : LTree A) : Prop :=
{
  v : A;
  l : LTree A;
  r : LTree A;
  p : unnode A t = Some (l, v, r);
  infl : Infinite l;
  infr : Infinite r;
}.

Print Infinite.

CoFixpoint mirror {A : Type} (t : LTree A) : LTree A :=
  match unnode A t with
  | None => leaf
  | Some (l, v, r) => node (mirror r) v (mirror l)
  end
.

Ltac d3 tup l v r :=
  let p := fresh "p" in destruct tup as [p r]; destruct p as [l v].
Ltac tryinv :=
  match goal with
  | [ H : _ |- _ ] => solve [inversion H; auto]
  | _ => idtac
  end.

Lemma bisym_refl : forall (A : Type) (t : LTree A), bisym t t.
Proof.
  cofix CH. intros.
  remember (unnode A t) as o eqn:H. induction o as [ tup | ].
  - d3 tup l v r. eapply binode; eauto.
  - apply bileaf; auto.
  Qed.

Lemma bisym_sym : forall (A : Type) (t1 t2 : LTree A), bisym t1 t2 -> bisym t2 t1.
Proof.
  cofix CH. intros. inversion H.
  - apply bileaf. destruct H0. split; auto.
  - eapply binode; eauto.
  Qed.

Lemma bisym_trans : forall (A : Type) (t1 t2 t3 : LTree A),
  bisym t1 t2 -> bisym t2 t3 -> bisym t1 t3.
Proof.
  cofix CH. intros. inversion H; inversion H0.
  - eapply bileaf. destruct H1. destruct H2. split; auto.
  - destruct H1. destruct (unnode A t2); tryinv.
  - destruct H6. destruct (unnode A t2); tryinv.
  - rewrite H2 in H6. inversion H6. subst.
    eapply binode; eauto.
  Qed.

Lemma pack_unnode : forall A t res,
  res = unnode A t ->
  t = {| unnode := res |}.
Proof.
  intros. case (ltree A t). intros. rewrite H0 in H. cbn in H.
  rewrite H. assumption.
Qed.

Lemma mirror_involution : forall (A : Type) (t : LTree A), bisym (mirror (mirror t)) t.
Proof.
  cofix CH. intros.
  remember (unnode A t) as o eqn:H. induction o as [ tup | ].
  - d3 tup l v r.
    eapply binode; eauto.
    rewrite (pack_unnode A t (Some (l,v,r))).
    cbn. auto. auto.
  - eapply bileaf. split; auto.
    erewrite (pack_unnode A t); eauto.
    cbn. reflexivity.
  Qed.

Lemma mirror_finite : forall (A : Type) (t : LTree A),
  Finite t -> Finite (mirror t).
Proof.
  intros.
  induction H; case (ltree A t) as [ m ].
  - apply finleaf. cbn. rewrite H0 in H. cbn in *. subst. cbn. reflexivity.
  - apply finnode with (l0 := mirror r) (v0 := v) (r0 := mirror l); eauto.
    subst. cbn in *. subst. cbn. reflexivity.
  Qed.

Lemma mirror_infinite : forall (A : Type) (t : LTree A),
  Infinite t -> Infinite (mirror t).
Proof.
  cofix CH. intros. inversion H.
  case (ltree A t) as [ m ]. induction m;
    rewrite H0 in p; cbn in p; inversion p; subst.
  apply Build_Infinite with (v := v) (l := mirror r) (r := mirror l); auto.
  Qed.

Lemma not_both : forall (A : Type) (t t' : LTree A), ~ (Finite t /\ Infinite t).
Proof.
  intros. intro H. destruct H as [ Hf Hi ].
  induction Hf; case (ltree A t) as [ m ].
  - inversion Hi. subst. cbn in *. subst. inversion p.
  - inversion Hi. subst. cbn in *. subst. inversion p. subst. auto.
  Qed.

(** **** Zadanie 2 - 4p *)
(*

    Znajdź taką rodzinę typów koinduktywnych C, że dla dowolnego
    typu A, C A jest w bijekcji z typem funkcji nat -> A. Przez
    bijekcję będziemy tu rozumieć funkcję, która ma odwrotność, z którą
    w obie strony składa się do identyczności.

    Uwaga: nie da się tego udowodnić bez użycia dodatkowych aksjomatów,
    które na szczęście są bardzo oczywiste i same się narzucają.

*)

CoInductive Stream (A : Type) : Type :=
{
    hd : A;
    tl : Stream A;
}.
Arguments hd {A}.
Arguments tl {A}.

CoInductive stream_eq {A : Type} (s1 s2 : Stream A) : Prop :=
{
    hds : hd s1 = hd s2;
    tls : stream_eq (tl s1) (tl s2);
}.

Lemma stream_eq_refl :
  forall (A : Type) (s : Stream A), stream_eq s s.
Proof.
  cofix CH. constructor; auto.
Qed.

Lemma stream_eq_sym :
  forall (A : Type) (s1 s2 : Stream A),
    stream_eq s1 s2 -> stream_eq s2 s1.
Proof.
  cofix CH.
  destruct 1 as [hds tls]. constructor; auto.
Qed.

Lemma stream_eq_trans :
  forall (A : Type) (s1 s2 s3 : Stream A),
    stream_eq s1 s2 -> stream_eq s2 s3 -> stream_eq s1 s3.
Proof.
  cofix CH.
  destruct 1 as [hds1 tls1], 1 as [hds2 tls2].
  constructor; eauto. rewrite hds1. assumption.
Qed.

Fixpoint nth {A : Type} (s : Stream A) (n : nat) :=
  match n with
  | O => s
  | S m => nth (tl s) m
  end
.

Definition stream_to_seq {A : Type} (s : Stream A) : nat -> A :=
  fun n => hd (nth s n).

CoFixpoint seq_to_stream {A : Type} (f : nat -> A) : Stream A :=
  {|
    hd := f 0;
    tl := seq_to_stream (fun n => f (S n))
  |}
.

Lemma fold_stream_to_seq : forall (A : Type) (s : Stream A),
  (fun n : nat => hd (nth (tl s) n)) = stream_to_seq (tl s).
  auto.
Qed.

Lemma stream_id : forall (A : Type) (s : Stream A),
  stream_eq s (seq_to_stream (stream_to_seq s)).
Proof.
  cofix CH. intros.
  constructor.
    cbn; unfold stream_to_seq; cbn; reflexivity.
    cbn. unfold stream_to_seq; cbn. rewrite fold_stream_to_seq. apply CH.
Qed.
    (* cbn. constructor.
      cbn; unfold stream_to_seq; cbn; reflexivity.
      simpl.
      apply CH.
Qed. *)

Require Import FunctionalExtensionality.

Lemma seq_id : forall (A : Type) (f : nat -> A),
  f = (stream_to_seq (seq_to_stream f)).
Proof.
  intros.
  apply functional_extensionality_dep. intro.
  generalize dependent f.
  induction x; intros.
  - cbn. reflexivity.
  - apply IHx with (f := fun n => f (S n)).
  Qed.

(** **** Zadanie 3 - 0p *)

(*

    Sprawdź, czy dobrze ufundowana jest następująca relacja porządku
    (mam nadzieję, że obrazek jest zrozumiały):
    0 < 1 < ... < ω < ω + 1 < ... < 2 * ω

     Oczywiście najpierw musisz wymyślić, w jaki sposób zdefiniować taką
     relację.

*)

(** **** Zadanie 4 - 4p *)

(*

    Niech (B, R) będzie typem wyposażonym w relację dobrze ufundowaną R.
    Zdefiniuj po współrzędnych relację porządku na funkcjach A -> B
    i rozstrzygnij, czy relacja ta jest dobrze ufundowana.

    Uwaga: zadanie jest trochę podchwytliwe.

*)

(** **** Zadanie 5 - 0p *)

(*

    Zdefiniuj pojęcie "nieskończonego łańcucha malejącego" (oczywiście
    za pomocą koindukcji) i udowodnij, że jeżeli relacja jest dobrze
    ufundowana, to nie ma nieskończonych łańcuchów malejących.

*)

(** **** Zadanie 6 - 0p *)

(*

    Zdefiniuj na listach porządek według długości i pokaż, że jest on
    dobrze ufundowany.

    Zdefiniuj przez rekursję dobrze ufundowaną funkcję rotn, która
    bierze liczbę n oraz listę i zwraca listę, w której bloki o
    długości dokładnie [n + 1] zostały odwrócone, np.
    rotn 0 [1; 2; 3; 4; 5; 6; 7] = [1; 2; 3; 4; 5; 6; 7]
    rotn 1 [1; 2; 3; 4; 5; 6; 7] = [2; 1; 4; 3; 6; 5; 7]
    rotn 2 [1; 2; 3; 4; 5; 6; 7] = [3; 2; 1; 6; 5; 4; 7]

    Wskazówka: zdefiniuj funkcją pomocniczą split, która dzieli listę
    na blok odpowiedniej długości i resztę listy.

    Następnie przyjmij, że funkcja rotn spełnia swoje równanie
    rekurencyjne (bonus, bardzo trudne: udowodnij, że faktycznie
    tak jest).

    Zdefiniuj relację opisującą wykres funkcji rotn. Pokaż, że
    definicja wykresu jest poprawna i pełna oraz wyprowadź z niej
    regułę indukcji funkcyjnej. Użyj jej, żeby udowodnić, że funkcja
    rotn jest inwolucją dla dowolnego n, tzn. rotn n (rotn n l) = l.

*)

(** **** Zadanie 7 - 7p *)

(*

    Zdefiniuj funkcję rotn (i wszystkie funkcje pomocnicze) jeszcze raz,
    tym razem za pomocą komendy Function. Porównaj swoje definicje wykresu
    oraz reguły indukcji z tymi automatycznie wygenerowanymi. Użyj taktyki
    functional induction, żeby jeszcze raz udowodnić, że rotn jest
    inwolucją (i wszystkie lematy też). Policz, ile pisania udało ci się
    dzięki temu zaoszczędzić.

    Czy w twoim rozwiązaniu są lematy, w których użycie indukcji funkcyjnej
    znacznie utrudnia przeprowadzenie dowodu? W moim jest jeden taki.

*)

(** **** Zadanie 8 - 0p *)

(*

    Zainstaluj plugin Equations:
    https://github.com/mattam82/Coq-Equations

    Przeczytaj tutorial:
    https://raw.githubusercontent.com/mattam82/Coq-Equations/master/doc/equations_intro.v

    Następnie znajdź jakiś swój dowód przez indukcję, który był skomplikowany
    i napisz prostszy dowód z potem za pomocą komendy [Equations] i taktyki
    [funelim].

    Dobrze byłoby, gdyby nie była to kolejna przeróbka poprzedniego zadania.

*)

(** **** Zadanie bonusowe - 10p *)

(*

    Nie ma to wprawdzie żadnego związku z tematem wykładu, ale miło by było
    pamiętać, że Coq to nie jest jakiś tam biedajęzyk programowania, tylko
    pełnoprawny system podstaw matematyki (no, prawie...). W związku z tym
    bonusowe zadanie:

    Pokaż, że nat <> Type.

*)


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.
Import TrM.

Context (G : ooGroup).
Local Notation B := classifying_space.

Section SomeLemmas.

  (* given a fibration [A : T -> U] and a dependent fibration [B (t : T) : (a : T a) -> U]
     we can form a product fibration [AxB t := { y : A t  &  B t y }].
     The lemma is that given a path [p] in [T] it is the same:
     [(transport AxB p x).1] and [transport A p x.1]
  *)
  Definition product_fibration
             {T : Type}
             (A : T -> Type) (B : forall (t : T) (a : A t), Type)
             : T -> Type
  := fun t => { y : A t & B t y}.

  Definition transport_on_first_coordinate
             {T : Type} (A : T -> Type) (B : forall (t : T) (a : A t), Type)
             {t1 t2 : T} (p : t1 = t2) (x : product_fibration A B t1)
             : (transport (product_fibration A B) p x).1 =
                 transport A p x.1.
  Proof.
    by induction p.
  Defined.

  (* a connected type is merely inhabited.
     I don't think this is done explicitly in the library
     although this argument is taken from the proof
     of [indecomposable_0connected] *)
  Definition isinhabitedifisconnected
             (A : Type)
             : IsConnected 0 A -> merely A.
  Proof.
    intro cc.
    assert (IsConnected -1 A) by refine (isconnected_pred -1 A).
    pose (mA := center (merely A)).
    exact mA.
  Defined.

  (* a (forall) product of mere propositions is a mere proposition.
     could not find this in the library *)
  Definition ishprop_productofhprop `{Funext}
             {A : Type} (P : A -> Type) (D : forall a, IsHProp (P a))
             : IsHProp (forall a, P a).
  Proof.
    refine (hprop_allpath _ _).
    intros f g.
    refine (path_forall _ _ _).
    intro a.
    apply (D a).
  Defined.

  (* a (binary) product of mere propositions is a mere proposition. *)
   Definition ishprop_bi_productofhprop `{Funext}
              {A B : Type} (pA : IsHProp A) (pB : IsHProp B)
              : IsHProp (A * B).
   Proof.
     refine (@trunc_prod (-1) A pA B pB ).
   Defined.

End SomeLemmas.

Section BasicDefinitions.

  (* non-empty action *)
  Definition isNonempty (A : ooAction G) : Type
  := merely (action_space A).

  (* transitive action *)
  Definition isTransitive (A : ooAction G) : Type
  := IsConnected 0 (sigT A).

  (* alternative def transitive action *)
  Definition isTransitive' (A : ooAction G) : Type
  := (isNonempty A) *
       (forall x y : A, merely {g : G & g # x = y}).

  (* free action *)
  Definition isFree (A : ooAction G) : Type
  := IsTrunc 0 (sigT A).

  (* alternative def free action *)
  Definition isFree' (A : ooAction G) : Type
  := forall a : A, Contr {g : G & g # a = a}.

  (* regular action *)
  Definition isRegular (A : ooAction G) : Type
  := Contr (sigT A).

  (* alternative def regular action *)
  Definition isRegular' (A : ooAction G) : Type
  := (isTransitive A) * (isFree A).

  (* the yoneda action *)
  Definition yoneda_action : ooAction G
  := fun b => point (B G) = b.

  (* an action on a space [X] induces a morphism [G -> Aut X] *)
  Definition action_induces_morph `{Univalence}
             (A : ooAction G)
             : ooGroupHom G (Aut A).
  Proof.
    simple refine (Build_pMap _ _ _ _).
      - intro b. exists (A b).
          (* todo: the following is probably already abstracted somewhere *)
        pose (mp := merely_path_is0connected _ (point (B G)) b).
          (* again, this should be a tactic *)
        simpl in mp; generalize mp; refine (Trunc_rec _); intro p.
        exact (tr (ap A p^)).
      - simple refine (path_sigma _ _ _ _ _).
          + reflexivity.
          + apply path_ishprop.
  Defined.

  (* alternative def faithful action *)
  Definition isFaithful `{Univalence}
               (A : ooAction G) : Type
  := IsEmbedding (action_induces_morph A).

  (* faithful action *)
  Definition isFaithful' (A : ooAction G) : Type
  := Contr {g : G & forall a : A, g # a = a}.

  (* orbit action: given an action [X] and a point [x] we can
     consider the orbit of this point. There is an
     action [orbit_action] that is the restriction of the action
     on [X] to the the orbit of [x] *)
  Definition orbit_action
             (X : ooAction G) (x : action_space X)
             : ooAction G
  := fun b => { y : X(b) &
                merely ((point (B G) ; x) = (b ; y)) }.

  (* stabilizer: given an action [A] and an element [x : A] we
     define the stabilizer of [x] as the connected component of
     [(point (B G)) ; x)] in [sigT A]

     todo: use [group_loops]
  *)
  Definition stabilizer
             (X : ooAction G) (x : action_space X)
             : ooGroup.
  Proof.
    pose (Ox := Build_pType (sigT (orbit_action X x))
                            ( (point (B G)) ; (x ; tr idpath ) ) ).
    refine (Build_ooGroup Ox _).
    (* this is how Mike does it in ooGroup.v *)
    cut (IsSurjection (unit_name (point Ox))).
    { intros; refine (conn_pointed_type (point _)). }
    apply BuildIsSurjection; simpl; intros [b ty].
    destruct ty as (y, p).
    strip_truncations. apply tr. exists tt.
    simple refine (path_sigma _ _ _ _ _).
      - exact (p ..1).
      - apply path_sigma_hprop. simpl.
        refine ((transport_on_first_coordinate _ _ _ _) @ _).
        exact (p ..2).
  Defined.

  (* there is a natural map from the stabilizer to the group *)
  Definition stabilizer_to_G (X : ooAction G) (x : action_space X) :
               ooGroupHom (stabilizer X x) G.
  Proof.
    simple refine (Build_pMap _ _ _ _).
      - exact pr1.
      - reflexivity.
  Defined.

End BasicDefinitions.

Section ProofsAboutTransitiveActions.

  (* a transitive action is non-empty *)
  Definition isnonempty_transitiveaction `{Univalence}
             (A : ooAction G)
             : isTransitive A -> isNonempty A.
  Proof.
    intro.
    unfold isNonempty. simpl.
    cut (Trunc (-1) (sigT A)).
    intros mSA.
    strip_truncations.
    cut (Trunc (-1) ((point (B G)) = mSA.1)).
    refine (Trunc_functor _ _).
      - intro p. exact (transport _ p^ (pr2 mSA)).
      - exact (merely_path_is0connected _ (point (B G)) (pr1 mSA)).
      - exact (isinhabitedifisconnected _ X).
  Defined.

 (** both definitions of transitive action are equivalent.
     we prove that both are mere propositions and that they
     are logically equivalent  *)

  (* being transitive is a mere property *)
  Definition ishProp_isTransitive `{Funext}
             (A : ooAction G)
             : IsHProp (isTransitive A)
  := ishprop_isconnected _ _.

  (* being transitive' is a mere property *)
  Definition ishProp_isTransitive' `{Funext}
             (A : ooAction G)
             : IsHProp (isTransitive' A).
  Proof.
    unfold isTransitive'.
    exact (ishprop_bi_productofhprop _ _).
  Defined.

  Definition transitive2transitive' `{Univalence}
             (A : ooAction G)
             : isTransitive A -> isTransitive' A.
  Proof.
    intro. unfold isTransitive'.
    refine ((isnonempty_transitiveaction A X) , _).
    intros x y.
    pose (mereg := @merely_path_is0connected _ _ X ((point (B G)) ; x)
                                                   ((point (B G)) ; y)).
    (* the following command takes some seconds *)
    simpl in mereg. simpl.
    cut (Trunc (-1) ((point (B G); x) = (point (B G); y))).
    refine (Trunc_functor _ _).
      - intro p. exact (p..1 ; p..2).
      - exact mereg.
  Defined.

  Definition transitive'2transitive `{Univalence}
             (A : ooAction G)
             : isTransitive' A -> isTransitive A.
  Proof.
    intro tr'. unfold isTransitive' in tr'.
    refine (is0connected_merely_allpath _ _).
      - cut (Trunc (-1) A).
          + intro mA. strip_truncations. exact (tr (point (B G) ; mA)).
          + exact (fst tr').
      - intros x y.
        pose (mp := snd tr').
        pose (mpx := @merely_path_is0connected _ _ _ (point (B G)) (pr1 x)).
        pose (mpy := @merely_path_is0connected _ _ _ (point (B G)) (pr1 y)).
        (* there is probably a more elegant way to do this. maybe
           strip_truncations or something similar should work here? *)
        generalize mpx, mpy.
        refine (Trunc_rec _).
        intro px.
        refine (Trunc_rec _).
        intro py.
        (* transport [x] and [y] to [A], and rememeber the paths used *)
        pose (tx := transport _ px^ (pr2 x)).
        pose (xetx := path_sigma _ x ((point (B G)) ; tx) px^ 1).
        pose (ty := transport _ py^ (pr2 y)).
        pose (yety := path_sigma _ y ((point (B G)) ; ty) py^ 1).
        pose (txety'' := mp tx ty).
        (* the transported [x] and [y] are equal in [A] *)
        generalize txety''.
        refine (Trunc_rec _).
        intro txety'.
        pose (txety := path_sigma _ ((point (B G)) ; tx)
                                    ((point (B G)) ; ty)
                                    (pr1 txety') (pr2 txety')).
        (* finally compose the equalities *)
        exact (tr (xetx @ txety @ yety^)).
  Defined.

  Definition transitiveequivtransitive' `{Univalence}
             (A : ooAction G)
             : IsEquiv (transitive2transitive' A)
  := isequiv_iff_hprop (transitive2transitive' A) (transitive'2transitive A).

End ProofsAboutTransitiveActions.

Section ProofsAboutFreeActions.

 (** both definitions of free action are equivalent.
     we prove that both are mere propositions and that they
     are logically equivalent  *)

  (* being free is a mere property *)
  Definition ishProp_isFree `{Funext}
             (A : ooAction G)
             : IsHProp (isFree A)
  := hprop_inO _ _ _.

  (* being free' is a mere property *)
  Definition ishProp_isFree' `{Funext}
             (A : ooAction G)
             : IsHProp (isFree' A)
  := ishprop_productofhprop _ _.

  (* we use [trunc_equiv] to prove this without univalence :) *)
  Definition free2free'
             (A : ooAction G)
             : isFree A -> isFree' A.
  Proof.
    intro X. intro a.
    pose (pathspacesigma := equiv_path_sigma _ (point (B G) ; a)
                                               (point (B G) ; a)).
    refine (trunc_equiv' _ pathspacesigma^-1).
    refine (contr_inhabited_hprop _ _).
    reflexivity.
  Defined.

  Definition free'2free `{Univalence}
             (A : ooAction G)
             : isFree' A -> isFree A.
  Proof.
      (* we reduce it to the case of loopspaces*)
    intro X. intros x y p. induction p.
    unfold isFree' in X.
    pose (mq := merely_path_is0connected _ (point (B G)) (pr1 x)).
      (* again, this should be a tactic *)
    simpl in mq; generalize mq; refine (Trunc_rec _); intro q.
    pose (tX := transport (fun b => forall a : A b,
                           Contr {g : b = b & transport A g a = a}) q X).
    pose (tXatx2 := tX (pr2 x)).
      (* we can probably avoid using univalence here *)
    pose (pathspacesigma := path_universe (equiv_path_sigma _ x x)).
      (* todo: improve this proof *)
    rewrite pathspacesigma in tXatx2.
    intro l.
    refine (contr_inhabited_hprop _ _).
    apply path_contr.
  Qed.

  Definition freeequivfree' `{Univalence}
             (A : ooAction G)
             : IsEquiv (free2free' A)
  := isequiv_iff_hprop (free2free' A) (free'2free A).

End ProofsAboutFreeActions.

Section ProofsAboutYonedaAction.

  (* the action space of the yoneda action is the group [G] *)
  Definition yoneda_acts_on_G : action_space yoneda_action = G
  := 1.

  (* the Yoneda action is regular *)
  Definition isRegular_yoneda : isRegular yoneda_action.
  Proof.
    apply contr_basedpaths.
  Defined.

End ProofsAboutYonedaAction.

Section ProofsAboutFaithfulActions.
  (* being faithful is a mere property *)
  Definition ishProp_isfaithful `{Univalence}
             (A : ooAction G)
             : IsHProp (isFaithful A).
  Proof.
    exact _.
  Defined.

  (* being faithful' is a mere property *)
  Definition ishProp_isfaithful' `{Funext}
             (A : ooAction G)
             : IsHProp (isFaithful' A)
  := hprop_inO _ _ _.

  (* todo: finish this equivalence
  Definition faithful2faithful' `{Univalence}
             (A : ooAction G)
             : isFaithful A -> isFaithful' A.
  Proof.
    intro X.
    simple refine (BuildContr _ _ _).
      - exists idpath. reflexivity.
      - unfold isFaithful in X.
  *)

End ProofsAboutFaithfulActions.

Section ProofsAboutStabilizer.

  (* how the map [Stab -> G] computes on paths *)
  Definition stabilizer_to_G_path
             (X : ooAction G) (x : action_space X) (l : stabilizer X x)
             : (stabilizer_to_G X x) l = l ..1.
  Proof.
    unfold stabilizer_to_G. unfold grouphom_fun. unfold loops_functor. simpl.
    refine (concat_1p _ @ _). refine (concat_p1 _ @ _).
    reflexivity.
  Defined.

  (* maybe we should coerce an element of a stabilizer to an
     element of the group? *)

  (* the stabilizer of [x] acts trivially on [x] *)
  Definition stab_acts_trivially
             {X : ooAction G} {x : action_space X} (l : stabilizer X x)
             : transport X ((stabilizer_to_G X x) l) x = x.
  Proof.
    pose (pr1l2 := pr1_path l..2).
    pose (pr := (transport_on_first_coordinate _ _ _ _)^ @ pr1l2).
    simpl in pr.
    refine (ap (fun path => transport X path x)
               (stabilizer_to_G_path _ _ l) @ _).
    apply pr.
  Defined.

End ProofsAboutStabilizer.

Section Cosets.

  (* relation of being in the same coset *)
  Definition in_coset_morph
             {H : ooGroup} (f : ooGroupHom H G) (b : B G)
             : (point (B G)) = b -> (point (B G)) = b -> Type
    := fun g1 g2 => hfiber f (g1 @ g2^).

  (* quotient given by coset relation *)
  Definition reltocoeq {A : Type} (R : A -> A -> Type) : Type
  := @Coeq {p : A * A & R (fst p) (snd p)} A (fst o pr1) (snd o pr1).

  (* action on cosets *)
  Definition action_cosets
             {H : ooGroup} (f : ooGroupHom H G)
             : ooAction G
  := fun b => reltocoeq (in_coset_morph f b).

  (* fiberwise map cosets action to orbit action *)
  Definition cosets_to_orbit
             {X : ooAction G} {x : action_space X} (b : B G)
             : (action_cosets (stabilizer_to_G X x) b) -> orbit_action X x b.
  Proof.
    simple refine (Coeq_rec _ _ _).
      - intro p. exists (p # x).
        apply tr. simple refine (path_sigma _ _ _ _ _).
          + simpl. exact p.
          + reflexivity.
      - intros. simpl.
        simple refine (path_sigma _ _ _ _ _).
          + simpl. induction b0 as (p, pp).
            apply moveL_transport_p. rewrite <- transport_pp.
            induction pp as (l, t).
            refine ( (ap (fun e => transport X e x) t^) @ _ ).
            pose (l1 := l ..1).
            pose (l2 := l ..2).
            pose (l21 := ap pr1 l2).
            pose (pr := (transport_on_first_coordinate _ _ _ _)^ @ l21).
            simpl in pr.

            refine (ap (fun path => transport X path x)
                       (stabilizer_to_G_path _ _ l) @ _).
            apply pr.
          + apply path_ishprop.
  Qed.

  (* this is false but it seems to be true for
     subgroups (i.e. when the map [B H -> B G] is fibered in set)
  (* this map is an equivalence *)
  Definition isequiv_cosets_to_orbit
               {X : ooAction G} {x : action_space X} (b : B G) :
                 IsEquiv (@cosets_to_orbit X x b).
  Proof.
  *)

End Cosets.

Section More.

(* other *)
  (* stabilizer: *)
  Definition stabilizer'
             (X : ooAction G) (x : action_space X)
             : ooGroup
  := group_loops (Build_pType (sigT (orbit_action X x))
                              ( (point (B G)) ; (x ; tr idpath ) ) ).

  (* map from stabilizer' to group *)
  Definition stabilizer'_to_G
             (X : ooAction G) (x : action_space X)
             : ooGroupHom (stabilizer' X x) G.
  Proof.
    simple refine (Build_pMap _ _ _ _).
      - intro bb.
        exact (pr1 (pr1 bb)).
      - reflexivity.
  Defined.

End More.