Require Import ZArith Lia.
Require Import ProofIrrelevance.
Require Import ASN1FP.Types.Bitstring ASN1FP.Types.BSaux
        ASN1FP.Aux.Roundtrip ASN1FP.Aux.Bits
        ASN1FP.Aux.StructTactics ASN1FP.Types.BitContainer
        ASN1FP.Aux.Tactics ASN1FP.Aux.Option.
Require Import ASN1FP.Conversion.Bitstring_Bsaux.

Section Definitions.

  (** * lengths *)

  Definition info_nblen := 24%nat.

  Definition nbs_nblen (b : BER_nbs) : nat :=
    match b with
    | short_nbs id co t s bb ff ee e m _ _ _ _ _ => 8 * (c2n co + 2)
    | long_nbs id co t s bb ff ee eo e m _ _ _ _ _ => 8 * (c2n co + 2)
    end.

  Definition content_nblen (b : BER_nbs) : nat :=
    match b with
    | short_nbs id co t s bb ff ee e m _ _ _ _ _ => 8 * (c2n co - 1)
    | long_nbs id co t s bb ff ee eo e m _ _ _ _ _ => 8 * (c2n co - 1)
    end.

  Lemma short_nblen_correct {l1 l2 : nat} (co : container l1) (ee : container l2)
    (m : container (8 * (c2n co - c2n ee - 2))) :
      (8 * (c2n ee + 1) + 8 * (c2n co - c2n ee - 2))%nat = (8 * (c2n co - 1))%nat.
  Proof.
    destruct co, ee, m; rename v into co, v0 into ee, v1 into m.
    uncont; clear L L0 N N0 l1 l2.
    generalize (nblen_positive m); intros.
    lia.
  Qed.

  Lemma long_nblen_correct {l1 l2 : nat} (co : container l1) (eo : container l2)
    (m : container (8 * (c2n co - c2n eo - 2))) :
      (8 + (8 * c2n eo + 8 * (c2n co - c2n eo - 2)))%nat = (8 * (c2n co - 1))%nat.
  Proof.
    destruct co, eo, m; rename v into co, v0 into eo, v1 into m.
    uncont; clear L L0 N N0 l1 l2.
    generalize (nblen_positive m); intros.
    lia.
  Qed.

  Lemma nbs_nblen_correct (b : BER_nbs) :
    (info_nblen + content_nblen b)%nat = nbs_nblen b.
  Proof.
    generalize (nbs_co_positive b).
    destruct b;
      unfold nbs_co, content_nblen, nbs_nblen, info_nblen;
      lia.
  Qed.

  Definition BER_nblen (b : Z) : nat :=
    let l := nblen b in
    l + (l mod 8)%nat.

  Lemma BER_nblen_correct (b : Z) :
    (nblen b <= BER_nblen b)%nat.
  Proof. unfold BER_nblen; lia. Qed.

  Definition bsaux_nblen (b : BER_bs_aux) :=
    match b with
    | special_aux val => nblen (bits_of_special val)
    | normal_aux b => nbs_nblen b
    end.

  (** * nbs -> cont *)

  Definition mk_info (b : BER_nbs) : container info_nblen :=
    match b with
    | short_nbs id co t s bb ff ee e m _ _ _ _ _ =>
         join_cont id
        (join_cont co
        (join_cont t
        (join_cont s
        (join_cont bb
        (join_cont ff ee
         )))))
    | long_nbs id co t s bb ff ee eo e m _ _ _ _ _ =>
         join_cont id
        (join_cont co
        (join_cont t
        (join_cont s
        (join_cont bb
        (join_cont ff ee
         )))))
    end.

  Definition append_info {l : nat} (b : BER_nbs) (c : container l) :=
    join_cont (mk_info b) c.

  Definition mk_content (b : BER_nbs) : container (content_nblen b) :=
    match b with
    | short_nbs id co t s bb ff ee e m _ _ _ _ _ =>
      cast_cont (join_cont e m) (short_nblen_correct co ee m)
    | long_nbs id co t s bb ff ee eo e m _ _ _ _ _ =>
      cast_cont (join_cont eo (join_cont e m)) (long_nblen_correct co eo m)
    end.

  Definition cont_of_nbs (b : BER_nbs) : container (nbs_nblen b) :=
    cast_cont (append_info b (mk_content b)) (nbs_nblen_correct b).

  (** * cont -> nbs *)

  Fact info_nblen_positive : (0 < info_nblen)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Definition cut_info {l : nat} (c : container (info_nblen + l)) (L : (0 < l)%nat) :
    (container info_nblen * container l) :=
    split_cont c info_nblen_positive L.

  Fact ilc1 : (0 < info_nblen - 8)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Fact ilc2 : (0 < info_nblen - 8 - 8)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Fact ilc3 : (0 < info_nblen - 8 - 8 - 1)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Fact ilc4 : (0 < info_nblen - 8 - 8 - 1 - 1)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Fact ilc5 : (0 < info_nblen - 8 - 8 - 1 - 1 - 2)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Fact ilc6 : (0 < info_nblen - 8 - 8 - 1 - 1 - 2 - 2)%nat.
  Proof. unfold info_nblen. lia. Qed.

  Program Definition split_info (c : container info_nblen) :
    (cont8 * cont8 * cont1 * cont1 * cont2 * cont2 * cont2) :=
    let '(id, c)  := cut_b8_cont c ilc1 in
    let '(co, c)  := cut_b8_cont c ilc2 in
    let '(t,  c)  := cut_b1_cont c ilc3 in
    let '(s,  c)  := cut_b1_cont c ilc4 in
    let '(bb, c)  := cut_b2_cont c ilc5 in
    let '(ff, ee) := cut_b2_cont c ilc6 in
    (id, co, t, s, bb, ff, ee).

  (* TODO: would be nice to clean this *)

  Definition split_cut_info {l : nat} (c : container (info_nblen + l)) (L : (0 < l)%nat) :=
    let '(info, content) := cut_info c L in
    let '(id, co, t, s, bb, ff, ee) := split_info info in
    (id, co, t, s, bb, ff, ee, content).

  Definition e_nblen_of_long_cont {l : nat} (c : container (8 + l)) (L : (0 < l)%nat) : nat :=
    c2n (fst (cut_b8_cont c L)).

  Definition try_cut_num (a b : nat) : option (a = b + (a - b))%nat :=
    match (Nat.eq_dec a (b + (a - b))) with
    | right _ => None
    | left H => Some H
    end.

  Lemma try_cut_num_works (a b : nat) (L : (0 < a - b)%nat) :
    is_Some_b (try_cut_num a b) = true.
  Proof.
    unfold try_cut_num.
    destruct (Nat.eq_dec a (b + (a - b))); simpl.
    reflexivity.
    lia.
  Qed.

  Definition cut_num (a b : nat) (L : (0 < a - b)%nat) :
    (a = b + (a - b))%nat.
  {
    generalize (try_cut_num_works a b L); intros.
    destruct (try_cut_num a b).
    exact e.
    inversion H.
  } Defined.

  Definition cut_cont {l : nat} (c : container l) (l1 : nat) (L : (0 < l - l1)%nat)
    : container (l1 + (l - l1)) :=
    cast_cont c (cut_num l l1 L).

  Definition try_cut_cont {l : nat} (c : container l) (l1 : nat)
    : option (container (l1 + (l - l1))) :=
      match le_lt_dec l1 0 with
      | left _ => None
      | right L1 =>
        match le_lt_dec (l - l1) 0 with
        | left _ => None
        | right L2 =>
        Some ((cut_cont c l1 L2))
        end
      end.

  Definition try_split_cont {l : nat} (c : container l) (l1 : nat) :=
      match le_lt_dec l1 0 with
      | left _ => None
      | right L1 =>
        match le_lt_dec (l - l1) 0 with
        | left _ => None
        | right L2 =>
        Some (split_cont (cut_cont c l1 L2) L1 L2)
        end
      end.

  Definition try_split_long_cont  {l : nat} (c : container (8 + l)) (L : (0 < l)%nat)
    : option (container 8 *
              container (e_nblen_of_long_cont c L) *
              container (l - e_nblen_of_long_cont c L)) :=
      let eo := fst (cut_b8_cont c L) in
      let em := snd (cut_b8_cont c L) in
      let eon := c2n eo in
      match try_split_cont em eon with
      | None => None
      | Some (e,m) =>
        Some (eo, e, m)
      end.

  Definition check_short_elen {l : nat} (ee : cont2) (e : container l) :=
    match Nat.eq_dec l (8 * (c2n ee + 1)) with
    | right _ => None
    | left E => Some (cast_cont e E)
    end.

  Definition check_long_elen {l : nat} (eo : cont8) (e : container l) :=
    match Nat.eq_dec l (8 * (c2n eo)) with
    | right _ => None
    | left E => Some (cast_cont e E)
    end.

  Definition check_short_mlen {l : nat} (co : cont8) (ee : cont2) (m : container l) :=
    match Nat.eq_dec l (8 * (c2n co - c2n ee - 2)) with
    | right _ => None
    | left M => Some (cast_cont m M)
    end.

  Definition check_long_mlen {l : nat} (co : cont8) (eo : cont8) (m : container l) :=
    match Nat.eq_dec l (8 * (c2n co - c2n eo - 2)) with
    | right _ => None
    | left M => Some (cast_cont m M)
    end.

  Definition construct_short_nbs
             {l1 l2 : nat}
             (id co : cont8)
             (t s : cont1) (bb ff ee : cont2)
             (e : container l1) (m : container l2)
    : option BER_nbs :=
    match (check_short_elen ee e) with
    | None => None
    | Some e =>
      match (check_short_mlen co ee m) with
      | None => None
      | Some m =>
        match Z.eq_dec (c2z id) real_id_b with
        | right _ => None
        | left VS1 =>
          match Z.eq_dec (c2z t) 1 with
          | right _ => None
          | left VS2 =>
            match Z_le_dec (c2z ee) 2 with
            | right _ => None
            | left VS3 =>
              match Z_le_dec 1 (c2z m) with
              | right _ => None
              | left VS4 =>
                match Z_le_dec (c2z co) 127 with
                | right _ => None
                | left VS5 =>
                Some (short_nbs id co t s bb ff ee e m VS1 VS2 VS3 VS4 VS5)
                end
              end
            end
          end
        end
      end
    end.

  Definition construct_long_nbs
             { l1 l2 : nat }
             (id co : cont8)
             (t s : cont1) (bb ff ee : cont2)
             (eo : cont8)
             (e : container l1) (m : container l2)
    : option BER_nbs :=
    match (check_long_elen eo e) with
    | None => None
    | Some e =>
      match (check_long_mlen co eo m) with
      | None => None
      | Some m =>
        match Z.eq_dec (c2z id) real_id_b with
        | right _ => None
        | left VL1 =>
          match Z.eq_dec (c2z t) 1 with
          | right _ => None
          | left VL2 =>
            match Z.eq_dec (c2z ee) 3 with
            | right _ => None
            | left VL3 =>
              match Z_le_dec 1 (c2z m) with
              | right _ => None
              | left VL4 =>
                match Z_le_dec (c2z co) 127 with
                | right _ => None
                | left VL5 =>
                 Some (long_nbs id co t s bb ff ee eo e m VL1 VL2 VL3 VL4 VL5)
                end
              end
            end
          end
        end
      end
    end.

  Definition nbs_of_cont {l : nat} (c : container l) :=
    match (try_cut_cont c info_nblen) with
    | None => None
    | Some c =>
      match le_lt_dec (l - info_nblen) 0 with
      | left _ => None
      | right L =>
        let '(id, co, t, s, bb, ff, ee, content) := split_cut_info c L in
        if (c2n ee =? 3)%nat
        then match (try_cut_cont content 8) with
             | None => None
             | Some content =>
               match le_lt_dec (l - info_nblen - 8) 0 with
               | left _ => None
               | right L =>
                 match (try_split_long_cont content L) with
                 | None => None
                 | Some (eo, e, m) =>
                     construct_long_nbs id co t s bb ff ee eo e m
                 end
               end
             end
        else match (try_split_cont content (8 * (c2n ee + 1))) with
             | None => None
             | Some (e, m) =>
                 construct_short_nbs id co t s bb ff ee e m
             end
      end
    end.

  (** * bsaux <-> cont *)

  Lemma bits_of_special_nonneg (val : BER_special) :
    0 <= bits_of_special val.
  Proof.
    destruct val; simpl.
    unfold pzero_b; lia.
    unfold nzero_b; lia.
    unfold pinf_b; lia.
    unfold ninf_b; lia.
    unfold nan_b; lia.
  Qed.

  Definition cont_of_bsaux (b : BER_bs_aux) : container (bsaux_nblen b) :=
    match b with
    | special_aux val =>
      let zval := bits_of_special val in
      cont (nblen zval) zval (bits_of_special_nonneg val) (Nat.le_refl (nblen zval))
    | normal_aux b => cont_of_nbs b
    end.

  (** * cont <-> Z *)

  Definition cont_of_BER_bits (b : Z) : option (container (BER_nblen b)) :=
    match (Z_gt_le_dec 0 b) with
    | left _ => None
    | right N => Some (cont (BER_nblen b) b N (BER_nblen_correct b))
    end.

  Definition bits_of_bsaux (b : BER_bs_aux) :=
    c2z (cont_of_bsaux b).

  Definition bits_of_bitstring (b : BER_bitstring) : Z :=
    bits_of_bsaux (bsaux_of_bitstring b).

  Definition mk_special_bsaux (b : Z) : option BER_bs_aux :=
    match classify_BER b with
    | Some pzero => Some (special_aux pzero)
    | Some nzero => Some (special_aux nzero)
    | Some pinf  => Some (special_aux pinf)
    | Some ninf  => Some (special_aux ninf)
    | Some nan   => Some (special_aux nan)
    | None       => None
    end.

  Definition bsaux_of_bits (b : Z) : option BER_bs_aux :=
    if b <? 0
    then None
    else match (mk_special_bsaux b) with
         | Some b => Some b
         | None =>
           match cont_of_BER_bits b with
           | None => None
           | Some c =>
             match (nbs_of_cont c) with
             | None => None
             | Some b => Some (normal_aux b)
             end
           end
         end.

  Definition bitstring_of_bits (b : Z) : option BER_bitstring :=
    match bsaux_of_bits b with
    | None => None
    | Some b => Some (bitstring_of_bsaux b)
    end.

End Definitions.

Section Correctness.

  Open Scope bool_scope.

  Definition cont_eqb {l1 l2 : nat} (c1 : container l1) (c2 : container l2) :=
    match c1, c2 with
    | cont _ v1 _ _, cont _ v2 _ _ => andb (Nat.eqb l1 l2) (Z.eqb v1 v2)
    end.

  Infix "=c=" := cont_eqb (at level 50).

  Definition BER_nbs_eqb (b1 b2 : BER_nbs) :=
    match b1, b2 with
    | short_nbs id1 co1 t1 s1 bb1 ff1 ee1 e1 m1 _ _ _ _ _,
      short_nbs id2 co2 t2 s2 bb2 ff2 ee2 e2 m2 _ _ _ _ _ =>
      (id1 =c= id2) && (co1 =c= co2) && (t1 =c= t2)   &&
      (s1 =c= s2)   && (bb1 =c= bb2) && (ff1 =c= ff2) &&
      (ee1 =c= ee2) && (e1 =c= e2)   && (m1 =c= m2)
    | long_nbs id1 co1 t1 s1 bb1 ff1 ee1 eo1 e1 m1 _ _ _ _ _,
      long_nbs id2 co2 t2 s2 bb2 ff2 ee2 eo2 e2 m2 _ _ _ _ _ =>
      (id1 =c= id2) && (co1 =c= co2) && (t1 =c= t2)   &&
      (s1 =c= s2)   && (bb1 =c= bb2) && (ff1 =c= ff2) &&
      (ee1 =c= ee2) && (eo1 =c= eo2) && (e1 =c= e2)   &&
      (m1 =c= m2)
    | _, _ => false
    end.

  Definition BER_bsaux_eqb (b1 b2 : BER_bs_aux) :=
    match b1, b2 with
    | special_aux z1, special_aux z2 => special_eqb z1 z2
    | normal_aux nbs1, normal_aux nbs2 =>
      BER_nbs_eqb nbs1 nbs2
    | _, _ => false
    end.

  Definition cont_eqb_pair {l11 l12 l21 l22 : nat}
             (p1 : container l11 * container l12)
             (p2 : container l21 * container l22) :=
    match p1 with
    | (c11, c12) =>
      match p2 with
      | (c21, c22) =>
        andb (c11 =c= c21) (c12 =c= c22)
      end
    end.

  Lemma add_small_div (a b x : Z) :
    0 < x ->
    0 <= b ->
    b < x ->
    (a * x + b) / x = a.
  Proof.
    intros OX OB BX.
    rewrite Z.div_add_l; try lia.
    rewrite Z.div_small; lia.
  Qed.

  Lemma split_join_cont_eqb {l1 l2 : nat} (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
        (c1 : container l1) (c2 : container l2) :
    cont_eqb_pair
      (split_cont (join_cont c1 c2) L1 L2)
      (c1, c2)
    = true.
  Proof.
    unfold split_cont, join_cont, cont_eqb_pair.
    destruct c1 as (v1, N1, L1').
    destruct c2 as (v2, N2, L2').
    simpl.
    repeat rewrite Nat.eqb_refl, Bool.andb_true_l.
    clear L1 L1' l1 L2.
    unfold nblen in L2'.
    rewrite two_power_nat_equiv.
    replace l2 with (Z.to_nat (Z.of_nat l2)) in L2' by apply Nat2Z.id.
    remember (Z.of_nat l2) as l; clear Heql l2.
    apply Z2Nat_pos_inj_le in L2'; try (generalize (Z.log2_nonneg v2); lia).
    assert (0 < l) by (generalize (Z.log2_nonneg v2); lia).
    destruct (Z.eq_dec v2 0); subst.
    - repeat rewrite Z.add_0_r.
      rewrite Z.div_mul, Z.mod_mul.
      repeat rewrite Z.eqb_refl; trivial.
      all: generalize (Z.pow_pos_nonneg 2 l); lia.
    - assert (L : Z.log2 v2 < l) by lia; clear L2'; apply Z.log2_lt_pow2 in L; try lia.
      assert (0 < 2^l) by (apply Z.pow_pos_nonneg; lia).
      remember (2^l) as x; clear Heqx n H l.
      split_andb_goal; debool.
      + apply add_small_div; assumption.
      + rewrite Z.add_comm.
        rewrite Z.mod_add; [|lia].
        apply Z.mod_small; lia.
  Qed.

  Lemma split_join_cont_eq {l1 l2 : nat} (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
        (c1 : container l1) (c2 : container l2) :
      (split_cont (join_cont c1 c2) L1 L2) = (c1, c2).
  Proof.
    generalize (split_join_cont_eqb L1 L2 c1 c2); intros H.
    unfold cont_eqb_pair in H.
    unfold cont_eqb in *.
    repeat break_match.
    repeat split_andb; debool; subst.
    rewrite proof_irrelevance with (p1 := N0) (p2 := N).
    rewrite proof_irrelevance with (p1 := L0) (p2 := L).
    rewrite proof_irrelevance with (p1 := N2) (p2 := N1).
    rewrite proof_irrelevance with (p1 := L4) (p2 := L3).
    reflexivity.
  Qed.

  Lemma split_join_cont_fst {l1 l2 : nat} (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
        (c1 : container l1) (c2 : container l2) :
    fst (split_cont (join_cont c1 c2) L1 L2) =c= c1 = true.
  Proof.
    generalize (split_join_cont_eqb L1 L2 c1 c2); intros.
    unfold cont_eqb_pair in H.
    break_match.
    split_andb.
    simpl.
    assumption.
  Qed.

  Lemma split_join_cont_snd {l1 l2 : nat} (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
        (c1 : container l1) (c2 : container l2) :
    snd (split_cont (join_cont c1 c2) L1 L2) =c= c2 = true.
  Proof.
    generalize (split_join_cont_eqb L1 L2 c1 c2); intros.
    unfold cont_eqb_pair in H.
    break_match.
    split_andb.
    simpl.
    assumption.
  Qed.

  Lemma cut_append_info {l : nat} (b : BER_nbs) (c : container l) (L : (0 < l)%nat)  :
    (fst (cut_info (append_info b c) L) =c= mk_info b) = true.
  Proof.
    unfold cut_info, append_info.
    apply split_join_cont_fst.
  Qed.

  Definition option_het_eq {A B : Type} (f : A -> B -> bool) : (option A -> option B -> bool) :=
    fun (a : option A) (b : option B) =>
      match a, b with
      | Some a, Some b => f a b
      | Some a, None   => false
      | None,   Some b => false
      | None,   None   => true
      end.

  Lemma nbs_is_not_special (b : BER_nbs) :
    classify_BER (c2z (cont_of_nbs b)) = None.
  Proof.
  Admitted.

  Lemma cont_eqb_refl {l : nat}
        (c : container l) :
    c =c= c = true.
  Proof.
    unfold cont_eqb.
    break_match.
    rewrite Nat.eqb_refl.
    rewrite Z.eqb_refl.
    reflexivity.
  Qed.

  Lemma cont_eqb_sym {l1 l2 : nat}
        (c1 : container l1)
        (c2 : container l2) :
    c1 =c= c2 = c2 =c= c1.
  Proof.
    unfold cont_eqb.
    repeat break_match.
    rewrite Nat.eqb_sym.
    rewrite Z.eqb_sym.
    reflexivity.
  Qed.

  Lemma cont_eqb_trans {l1 l2 l3 : nat}
        (c1 : container l1)
        (c2 : container l2)
        (c3 : container l3) :
    c1 =c= c2 = true ->
    c2 =c= c3 = true ->
    c1 =c= c3 = true.
  Proof.
    intros H1 H2.
    unfold cont_eqb in *.
    repeat break_match.
    repeat split_andb; debool.
    subst. rewrite Nat.eqb_refl, Z.eqb_refl.
    reflexivity.
  Qed.

  Lemma BER_nbs_eqb_refl (b : BER_nbs) :
    BER_nbs_eqb b b = true.
  Proof.
    unfold BER_nbs_eqb.
    break_match.
    all: repeat rewrite cont_eqb_refl; reflexivity.
  Qed.

  Lemma BER_nbs_eqb_sym (b1 b2 : BER_nbs) :
    BER_nbs_eqb b1 b2 = BER_nbs_eqb b2 b1.
  Proof.
    unfold BER_nbs_eqb.
    repeat break_match; try reflexivity.
    all: rewrite cont_eqb_sym with (c1 := id).
    all: rewrite cont_eqb_sym with (c1 := co).
    all: rewrite cont_eqb_sym with (c1 :=  t).
    all: rewrite cont_eqb_sym with (c1 :=  s).
    all: rewrite cont_eqb_sym with (c1 := bb).
    all: rewrite cont_eqb_sym with (c1 := ff).
    all: rewrite cont_eqb_sym with (c1 := ee).
    all: try (rewrite cont_eqb_sym with (c1 := eo)).
    all: rewrite cont_eqb_sym with (c1 := e).
    all: rewrite cont_eqb_sym with (c1 := m).
    all: reflexivity.
  Qed.

  Lemma BER_nbs_eqb_trans (b1 b2 b3 : BER_nbs) :
    BER_nbs_eqb b1 b2 = true ->
    BER_nbs_eqb b2 b3 = true ->
    BER_nbs_eqb b1 b3 = true.
  Proof.
    intros H1 H2.
    unfold BER_nbs_eqb in *.
    repeat break_match;
      try (inversion H2; rewrite ->H2); try (inversion H1; rewrite ->H1).
    all: repeat split_andb.
    all: rewrite cont_eqb_trans with (c2 := id1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 := co1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 :=  t1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 :=  s1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 := bb1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 := ff1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 := ee1); [| assumption | assumption].
    all: try (rewrite cont_eqb_trans with (c2 := eo1); [| assumption | assumption]).
    all: rewrite cont_eqb_trans with (c2 := e1); [| assumption | assumption].
    all: rewrite cont_eqb_trans with (c2 := m1); [| assumption | assumption].
    all: reflexivity.
  Qed.

  Lemma split_cast_join {l1 l2 : nat}
        (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
        (c1 : container l1) (c2 : container l2) :
        split_cont (cast_cont (join_cont c1 c2) (eq_refl (l1 + l2)%nat)) L1 L2 = (c1, c2).
  Proof. simpl; apply split_join_cont_eq. Qed.

  (** * care *)
  Lemma split_cut_join {l1 l2 : nat}
        (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
        (L2' : (0 < l1 + l2 - l1)%nat)
        (c1 : container l1) (c2 : container l2) :
    cont_eqb_pair
      (split_cont (cut_cont (join_cont c1 c2) l1 L2') L1 L2')
      (c1, c2)
    = true.
  Proof.
    unfold cont_eqb_pair.
    break_match; rename c0 into r_c1, c into r_c2.
    unfold cut_cont in Heqp.
    generalize (split_cast_join L1 L2 c1 c2); intro.
    unfold cut_num in Heqp.
    unfold try_cut_num in Heqp.
  Admitted.

  Lemma cont_eq_nbs_eq {l1 l2 : nat} (c1 : container l1) (c2 : container l2) :
    c1 =c= c2 = true ->
    (option_het_eq BER_nbs_eqb) (nbs_of_cont c1) (nbs_of_cont c2) = true.
  Proof.
    intros H.
    destruct c1 as (v1, N1, L1).
    destruct c2 as (v2, N2, L2).
    simpl in H; split_andb; debool;
      subst; rename l2 into l; rename v2 into v.
    rewrite proof_irrelevance with (p1 := N2) (p2 := N1).
    rewrite proof_irrelevance with (p1 := L2) (p2 := L1).
    unfold option_het_eq.
    break_match.
    rewrite BER_nbs_eqb_refl; reflexivity.
    reflexivity.
  Qed.

  Theorem nbs_cont_roundtrip (b : BER_nbs) :
    (option_het_eq BER_nbs_eqb) (nbs_of_cont (cont_of_nbs b)) (Some b) = true.
  Proof.
    unfold option_het_eq.
    break_match; [rename b0 into r_b |].
    - (* backward pass successful *)
      unfold nbs_of_cont, cont_of_nbs in Heqo.
      repeat break_match.
      inversion Heqo.
      inversion Heqo.
      subst.
      unfold try_cut_cont in Heqo0.
      repeat break_match; inversion Heqo0; clear Heqo0; subst c.
      unfold split_cut_info in Heqp.
      break_match.
  Admitted.

  Definition cont_len {l : nat} (c : container l) := l.

  Lemma cont_eq_cont_len_eq {l : nat}
        (c1 c2 : container l) :
    c1 = c2 ->
    cont_len c1 = cont_len c2.
  Proof. destruct c1, c2. reflexivity. Qed.

  Lemma cast_cont_len_eq {l1 l2 : nat}
        {c1 : container l1}
        {E : (l1 = l2)%nat} :
    cont_len (cast_cont c1 E) =
    cont_len c1.
  Proof. subst. reflexivity. Qed.

  Lemma join_cont_len_sum {l1 l2 : nat}
        (c1 : container l1) (c2 : container l2) :
    cont_len (join_cont c1 c2) = (cont_len c1 + cont_len c2)%nat.
  Proof. destruct c1, c2. unfold cont_len. reflexivity. Qed.

  Lemma BER_nblen_nbs_nblen (b : BER_nbs)
        (v : Z) (N : 0 <= v) (L : (nblen v <= nbs_nblen b)%nat) :
      cont_of_nbs b = cont (nbs_nblen b) v N L ->
      BER_nblen v = nbs_nblen b.
  Proof.
    intros H.
    unfold BER_nblen, nbs_nblen in *.
    unfold cont_of_nbs, append_info, mk_info, mk_content in H.

    destruct b.
    destruct id as (vid, Nid, Lid).
    destruct co as (vco, Nco, Lco).
    unfold join_cont at 2 in H.
    unfold join_cont at 2 in H.
    unfold content_nblen in H.
  Admitted.

  Lemma cont_of_bits_of_cont_of_nbs (b : BER_nbs) (l : 0 <= c2z (cont_of_nbs b)) :
      cont (BER_nblen (c2z (cont_of_nbs b)))
           (c2z (cont_of_nbs b))
           l
           (BER_nblen_correct (c2z (cont_of_nbs b)))
      =c=
      cont_of_nbs b = true.
  Proof.
    simpl.
    break_match.
    split_andb_goal; debool; simpl.
    apply (BER_nblen_nbs_nblen b v N L); assumption.
    reflexivity.
  Qed.

  Theorem bsaux_bits_roundtrip (b : BER_bs_aux) :
    roundtrip_option
        BER_bs_aux Z BER_bs_aux
        (Some_ize bits_of_bsaux)
        bsaux_of_bits
        BER_bsaux_eqb
        b.
  Proof.
    unfold roundtrip_option, bool_het_inverse'; simpl; intros T; clear T.
    unfold bsaux_of_bits, bits_of_bsaux.
    repeat break_match; inversion Heqo; clear Heqo; subst; debool.
    - unfold cont_of_bsaux in *.
      break_match.
      + (* special *)
        unfold mk_special_bsaux in *.
        destruct val.
        all: simpl in *.
        all: inversion Heqo0.
        all: reflexivity.
      + (* normal *)
        contradict Heqo0.
        unfold mk_special_bsaux.
        unfold bsaux_nblen.
        rewrite nbs_is_not_special.
        intros H; inversion H.
    - unfold BER_bsaux_eqb.
      break_match; subst b.

      + (* was special, decoded as nbs *)
        subst.
        contradict Heqo0.
        unfold mk_special_bsaux, c2z, cont_of_bsaux, bits_of_special, classify_BER.
        simpl.
        repeat break_match; discriminate.

      + (* was nbs, decoded as nbs *)
        rename b0 into b.
        rename b1 into r_b.

        (** * care: might be losing information *)
        clear Heqo0 Heqb1.

        unfold cont_of_bsaux in *.
        unfold cont_of_BER_bits in Heqo1.
        break_match; inversion Heqo1; subst c; clear Heqo1.
        generalize (cont_of_bits_of_cont_of_nbs b l); intros H; rewrite cont_eqb_sym in H.
        generalize (cont_eq_nbs_eq
                   (cont_of_nbs b)
                   (cont (BER_nblen (c2z (cont_of_nbs b)))
                         (c2z (cont_of_nbs b))
                         l
                         (BER_nblen_correct (c2z (cont_of_nbs b)))) H);
          intros H1.
        unfold bsaux_nblen in *.
        rewrite Heqo2 in H1.
        unfold option_het_eq in H1; break_match; inversion H1; clear H2.
        generalize (nbs_cont_roundtrip b); intros H2.
        unfold option_het_eq in H2; break_match; inversion H2; clear H3.
        rewrite H1.
        rewrite BER_nbs_eqb_trans with (b2 := b0).
        reflexivity.
        inversion Heqo; rewrite <-H3; rewrite BER_nbs_eqb_sym; assumption.
        assumption.
    - admit. (* trivial *)
    - admit.
    - admit. (* trivial *)
  Admitted.

End Correctness.


From stdpp Require Import numbers list.

Inductive ListExpression (A : Type) :=
| NilExpression
| VarExpression (x : list A)
| ConsExpression (head : A) (tail : ListExpression A)
| AppExpression (l1 l2 : ListExpression A).

Fixpoint interpret {A : Type} (expression : ListExpression A) : list A :=
  match expression with
  | NilExpression _ => []
  | VarExpression _ x => x
  | ConsExpression _ a b => a :: interpret b
  | AppExpression _ l1 l2 => interpret l1 ++ interpret l2
  end.

Inductive ListExpressionFlattenedTerm (A : Type) :=
| Singleton (x : A)
| AnyList (x : list A).

Fixpoint flatten {A : Type} (expression : ListExpression A) : list (ListExpressionFlattenedTerm A) :=
  match expression with
  | (NilExpression _) => []
  | (VarExpression _ x) => [AnyList _ x]
  | (ConsExpression _ head tail) => [Singleton _ head] ++ flatten tail
  | (AppExpression _ l1 l2) => flatten l1 ++ flatten l2
  end.

Fixpoint interpretFlattened {A : Type} (flattenedExpression : list (ListExpressionFlattenedTerm A)) :=
  match flattenedExpression with
  | [] => []
  | (Singleton _ x :: tail) => x :: interpretFlattened tail
  | (AnyList _ x :: tail) => x ++ interpretFlattened tail
  end.

Lemma flattenCorrect {A : Type} (expression : ListExpression A) : interpret expression = interpretFlattened (flatten expression).
Proof.
  assert (h1 : forall head expression, interpret (ConsExpression A head expression) = head :: interpret expression). { unfold interpret. easy. }
  assert (h2 : forall head expression, flatten (ConsExpression A head expression) = [Singleton _ head] ++ flatten expression). { unfold interpret. easy. }
  assert (h3 : forall expression1 expression2, interpret (AppExpression A expression1 expression2) = interpret expression1 ++ interpret expression2). { unfold interpret. easy. }
  assert (h4 : forall expression1 expression2, flatten (AppExpression A expression1 expression2) = flatten expression1 ++ flatten expression2). { unfold flatten. easy. }
  assert (h5 : forall expression1 expression2 : ListExpression A, interpretFlattened (flatten expression1 ++ flatten expression2) = interpretFlattened (flatten expression1) ++ interpretFlattened (flatten expression2)).
  { intro expression1. induction expression1.
    - simpl. easy.
    - simpl. rewrite app_nil_r. easy.
    - intros. simpl. rewrite IHexpression1. easy.
    - intros. simpl. rewrite <- app_assoc. rewrite <- h4. repeat rewrite IHexpression1_1. rewrite h4. rewrite IHexpression1_2. rewrite app_assoc. easy. }
  induction expression.
  - easy.
  - simpl. rewrite app_nil_r. reflexivity.
  - rewrite h1, h2. simpl. rewrite IHexpression. reflexivity.
  - rewrite h3, h4, h5, <- IHexpression1, <- IHexpression2. reflexivity.
Qed.

Lemma listsEqualReflect {A : Type} (expression1 expression2 : ListExpression A) : interpretFlattened (flatten expression1) = interpretFlattened (flatten expression2) -> interpret expression1 = interpret expression2.
Proof.
  intro h. repeat rewrite flattenCorrect. easy.
Qed.

Ltac listExpressionReify me :=
  match me with
  | nil => NilExpression
  | ?head :: ?tail =>
    let r1 := listExpressionReify head in
    let r2 := listExpressionReify tail in
      constr:(ConsExpression _ r1 r2)
  | ?l1 ++ ?l2 =>
    let r1 := listExpressionReify l1 in
    let r2 := listExpressionReify l2 in
      constr:(AppExpression _ r1 r2)
  | _ => constr:(VarExpression _ me)
  end.

Ltac listsEqual :=
  match goal with
  | [|- ?me1 = ?me2] =>
    let r1 := listExpressionReify me1 in
    let r2 := listExpressionReify me2 in
      change (interpret r1 = interpret r2);
        apply listsEqualReflect; simpl; repeat rewrite app_nil_r; reflexivity
  end.

Lemma test0 (l1 : list nat) (x : nat) : [x] ++ l1 = x :: l1.
Proof. listsEqual. Qed.

Lemma test1 (l1 l2 l3 : list nat) (x : nat) : l1 ++ [x] ++ l2 ++ l3 = l1 ++ (x :: l2) ++ l3.
Proof. listsEqual. Qed.

Lemma test2 (a b c d e : nat) : [a; b; c] ++ [] ++ [d; e] = [a; b; c; d; e] ++ [] ++ [].
Proof. listsEqual. Qed.

Lemma test3 (l1 l2 l3 : list nat) (x : nat) : l1 ++ [x] ++ l2 ++ l3 = l1 ++ (x :: l2 ++ l3).
Proof. listsEqual. Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                        Monotonic functions                               *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                Monotony.v                                *)
(****************************************************************************)

Require Import Prelude_Paths.
Require Import Prelude_Implicants.
Require Import Prelude_BDT.
Require Import CanonBDDs.rauzy.algorithme1.Boolean_functions.
Require Import CanonBDDs.rauzy.algorithme1.BDTs.

(*----------              Order on Assignments                    -----------*)

Definition Inf (A1 A2 : Assign) := forall i : nat, A1 i = true -> A2 i = true.

Lemma Inf_refl : forall A : Assign, Inf A A.
Proof.
unfold Inf in |- *; auto with arith.
Qed.

Lemma Inf_trans :
 forall A1 A2 A3 : Assign, Inf A1 A2 -> Inf A2 A3 -> Inf A1 A3.
Proof.
unfold Inf in |- *; auto with arith.
Qed.

Lemma Upd_preserves_Inf :
 forall A1 A2 : Assign,
 Inf A1 A2 -> forall (i : nat) (b : bool), Inf (Upd A1 i b) (Upd A2 i b).
Proof.
intros A1 A2 A1_Inf_A2 i b.
unfold Inf in |- *.
intro j.
unfold Inf in A1_Inf_A2.
unfold Upd in |- *; elim (eq_nat_dec i j); auto with arith.
Qed.

Lemma Divides_Inf :
 forall p1 p2 : Path,
 Divides p1 p2 ->
 forall A1 A2 : Assign,
 Assignment_of p1 A1 -> Assignment_of p2 A2 -> Inf A1 A2.
Proof.
intros p1 p2.
unfold Divides in |- *; intro Hd.
intros A1 A2 H1.
elim H1; intros H1_true H1_false.
intro H2; elim H2; intros H2_true H2_false.
unfold Inf in |- *; intros i Hi.
apply H2_true.
apply Hd; apply Inv_Assignment_of_true with A1; assumption.
Qed.

Lemma Anil_lowest : forall An A : Assign, Assignment_of Nil An -> Inf An A.
Proof.
intros An A.
unfold Assignment_of, Inf in |- *.
simple induction 1; intros H1 H2 i Hi.
absurd (true = false);
 [ exact diff_true_false | elim Hi; apply H2; exact (in_nil (a:=i)) ].
Qed.

(*----------------        Monotony        ----------------------------*)

Definition Monotonic (f : BF) :=
  forall A1 A2 : Assign, Inf A1 A2 -> f A1 = true -> f A2 = true.

Lemma BF_eq_Mon_Mon :
 forall f1 f2 : BF, BF_eq f1 f2 -> Monotonic f1 -> Monotonic f2.
Proof.
intros f1 f2 Heq.
unfold Monotonic in |- *; intro H_f1.
intros A1 A2 A1_Inf_A2 H1.
unfold BF_eq in Heq.
apply trans_equal with (f1 A2);
 [ auto with arith | apply H_f1 with A1; try assumption ].
apply trans_equal with (f2 A1); auto with arith.
Qed.

Lemma Mon_Frestr_Mon :
 forall (f : BF) (i : nat) (b : bool),
 Monotonic f -> Monotonic (Frestr f i b).
Proof.
intros f i b.
unfold Monotonic, Frestr in |- *; intros f_Mon A1 A2 A1_Inf_A2.
intro; apply f_Mon with (Upd A1 i b); try assumption.
apply Upd_preserves_Inf; trivial with arith.
Qed.

Lemma Mon_node_Mon_sons :
 forall (i : nat) (h l : BDT),
 OBDT (Node i h l) ->
 Monotonic (Fun (Node i h l)) -> Monotonic (Fun h) /\ Monotonic (Fun l).
Proof.
intros i h l Node_ordered Node_Mon.
split.
(*  left  *)
rewrite (Choice_left i h l).
apply BF_eq_Mon_Mon with (Frestr (Fun (Node i h l)) i true);
 [ apply Choice_Fun_eq_Fun_Choice; auto with arith
 | apply Mon_Frestr_Mon; assumption ].
(*  right *)
rewrite (Choice_right i h l).
apply BF_eq_Mon_Mon with (Frestr (Fun (Node i h l)) i false);
 [ apply Choice_Fun_eq_Fun_Choice; auto with arith
 | apply Mon_Frestr_Mon; assumption ].
Qed.

Lemma Bottom_implicant :
 forall f : BF, Monotonic f -> Implicant Nil f -> BF_eq f TRUE.
Proof.
intros f H1f H2f.
unfold BF_eq in |- *; intro A; unfold TRUE in |- *; simpl in |- *.
elim (Ass_of_well_defined Nil); intros An Def_An.
unfold Monotonic in H1f.
apply H1f with An;
 [ apply Anil_lowest; trivial with arith
 | elim (inv_Implicant Nil f H2f); intros Ha Hb; apply Hb; trivial with arith ].
Qed.

Lemma Divides_implic_implic :
 forall f : BF,
 Monotonic f ->
 forall p : Path,
 Implicant p f ->
 forall p' : Path, Divides p p' -> Ordered p' -> Implicant p' f.
Proof.
intros f Hf p Hp p' HDp' HOp'.
apply Def_Implicant; [ assumption | idtac ].
intros Ap' Def_Ap'.
elim (Ass_of_well_defined p); intros Ap Def_Ap.
unfold Monotonic in Hf; apply Hf with Ap.
apply Divides_Inf with p p'; try assumption.
elim (inv_Implicant p f Hp); auto with arith.
Qed.

Lemma L13 :
 forall f : BF,
 Monotonic f ->
 forall p : Path,
 ~ Implicant p f ->
 Ordered p -> forall p' : Path, Divides p' p -> ~ Implicant p' f.
Proof.
intros f Hf p HIp HOp p' Hp'.
apply Contra with (Implicant p f);
 [ intro H; apply Divides_implic_implic with p'; assumption | assumption ].
Qed.

Lemma L15 :
 forall (i : nat) (h l : BDT),
 OBDT (Node i h l) ->
 Monotonic (Fun (Node i h l)) ->
 forall p : Path,
 Ordered (Cons i p) -> Implicant p (Fun l) -> Implicant p (Fun h).
Proof.
intros i h l HO HM p H1p H2p.
apply L40 with i l; [ assumption | idtac ].
apply Divides_implic_implic with p;
 [ assumption | idtac | trivial with arith | assumption ].
apply L10; [ apply L11; trivial with arith | assumption ].
Qed.

Lemma Fcst_monotonic : forall b : bool, Monotonic (Fcst b).
Proof.
unfold Monotonic in |- *; auto with arith.
Qed.


Require Export low_mods.

Fixpoint AT (alpha : SecOrder) : bool :=
  match alpha with
  | predSO _ _ => true
  | conjSO alpha1 alpha2 => if AT alpha1 then AT alpha2 else false
  | _ => false
  end.

Lemma AT_conjSO_l : forall rel1 rel2,
  AT (conjSO rel1 rel2) = true ->
  AT rel1 = true.
Proof.
  intros rel1 rel2 H. simpl in H.
  if_then_else_dest_blind; auto.
Qed.

Lemma AT_conjSO_r : forall rel1 rel2,
  AT (conjSO rel1 rel2) = true ->
  AT rel2 = true.
Proof.
  intros rel1 rel2 H. simpl in H.
  if_then_else_dest_blind; auto.
  discriminate.
Qed.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq choice fintype.
From mathcomp Require Import finfun bigop prime binomial ssralg.
Require Import Reals ssrR.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.

Local Open Scope ring_scope.

Delimit Scope R_scope with CR.

Definition Req_bool (a b : R) : bool :=
  match Req_EM_T a b with left _ => true | _ => false end.

Lemma eqRP : Equality.axiom Req_bool.
Proof.
move=> a b. apply: (iffP idP); rewrite /Req_bool; by case: (Req_EM_T a b).
Qed.

Canonical R_eqMixin := EqMixin eqRP.
Canonical R_eqType := EqType R R_eqMixin.

Axiom R_choiceMixin : Choice.mixin_of R.
Canonical R_choice := ChoiceType R R_choiceMixin.

Definition R_zmodMixin := ZmodMixin addRA addRC add0R Rplus_opp_l.
Canonical R_zmodType := ZmodType R R_zmodMixin.

Search (R1 <> R0).

Lemma R1dR0 : R1 != R0. Proof. apply/eqP; exact R1_neq_R0. Qed.

Definition R_ringMixin := RingMixin mulRA mul1R mulR1 mulRDl mulRDr R1dR0.
Canonical R_ringType := RingType R R_ringMixin.

Canonical R_comRingType := ComRingType R mulRC.

Lemma Rinv_r' : forall x : R, x != 0 -> Rinv x * x = 1.
Proof. by move=> x /eqP /Rinv_l_sym H; rewrite -[_ * _]H. Qed.

Axiom Rinv_R0 : (/ 0 = 0)%CR.

Definition R_unitRingMixin := FieldUnitMixin Rinv_r' Rinv_R0.
Canonical R_unitRingType := UnitRingType R R_unitRingMixin.

Canonical R_comUnitRingType := Eval hnf in [comUnitRingType of R].

Definition R_FieldMixin := @FieldMixin _ _ Rinv_r' Rinv_R0.
Definition R_IntegralMixin := FieldIdomainMixin R_FieldMixin.
Canonical R_idomainType := IdomainType R R_IntegralMixin.
Canonical R_fieldType := FieldType R R_FieldMixin.

From mathcomp Require Import ssrnum.

(*RealLeMixin
     : forall (R : idomainType) (le lt : rel R) (norm : R -> R),
       (forall x y : R, le 0 x -> le 0 y -> le 0 (x + y)) ->
       (forall x y : R, le 0 x -> le 0 y -> le 0 (x * y)) ->
       (forall x : R, le 0 x -> le x 0 -> x = 0) ->
       (forall x y : R, le 0 (y - x) = le x y) ->
       (forall x : R, le 0 x || le x 0) ->
       (forall x : R, norm (- x) = norm x) ->
       (forall x : R, le 0 x -> norm x = x) ->
       (forall x y : R, lt x y = (y != x) && le x y) -> Num.mixin_of R*)

Delimit Scope Rb_scope with Rb.
Lemma addR_ge0 : (forall x y : R, 0 <b= x -> 0 <b= y -> 0 <b= x + y)%Rb.
Proof.
move=> x y /RleP Hx /RleP Hy. apply/RleP. by apply ssrR.addR_ge0.
Qed.

Lemma mulR_ge0 : (forall x y : R, 0 <b= x -> 0 <b= y -> 0 <b= x * y)%Rb.
Proof.
move=> x y /RleP Hx /RleP Hy. apply/RleP. by apply ssrR.mulR_ge0.
Qed.

Lemma le_ge_0 : (forall x : R, 0 <b= x -> x <b= 0 -> x = 0)%Rb.
Proof. move=> x /RleP Hx /RleP Hy. by apply Rle_antisym. Qed.

Require Import Fourier.

Lemma subR_le0 : (forall x y : R, 0 <b= (y - x) = (x <b= y))%Rb.
Proof.
move=> x y.
move Hlhs : (0 <b= y - x)%Rb => [|].
  move/RleP in Hlhs.
  symmetry.
  apply/RleP.
  by fourier.
symmetry.
apply/RleP.
move/RleP in Hlhs.
contradict Hlhs.
by fourier.
Qed.

Lemma or_le0 : forall x : R, (0 <b= x)%Rb || (x <b= 0)%Rb.
Proof.
move=> x; apply/orP.
case: (Rle_or_lt 0 x).
left; by apply/RleP.
right; apply/RleP.
by apply Rlt_le.
Qed.

Lemma Rabs_le0 : (forall x : R, (0 <b= x)%Rb -> Rabs x = x).
Proof. move=> x /RleP. by apply Rabs_pos_eq. Qed.

Lemma Rltn_neqAle_new : forall m n : R, (m <b n)%Rb = (n != m) && (m <b= n)%Rb.
Proof. move=> x y. by rewrite Rlt_neqAle eq_sym. Qed.

Definition R_RealLeMixin := RealLeMixin addR_ge0 mulR_ge0 le_ge_0 subR_le0 or_le0 Rabs_Ropp Rabs_le0 Rltn_neqAle_new.

Canonical R_numDomainType := NumDomainType R R_RealLeMixin.
Canonical R_numFieldType := [numFieldType of R].
Canonical R_realDomainType := RealDomainType R or_le0.
Canonical R_realFieldType := [realFieldType of R].

(* TODO: archimedian also corresponds to a stucture *)


(* Check exportation of Argument Scopes even without import of modules *)

Require Import ZArith.

Module A.
Definition opp := Zopp.
End A.
Check (A.opp 3).


Require Import Bool Arith List Omega.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Sorting.Permutation.
Import ListNotations.

Module WXFacts_fun (E:DecidableType) (Import Map:FMapInterface.WSfun E).
Module MapF := FMapFacts.WFacts_fun E Map.
Module MapProperties := FMapFacts.WProperties_fun E Map.
Section XFacts.
  Notation eq_dec := E.eq_dec.
  Context {elt: Type}.
  Implicit Types m: t elt.
  Implicit Types x y z: key.
  Implicit Types e: elt.
  Notation Partition := MapProperties.Partition.
  Notation Disjoint := MapProperties.Disjoint.
  Notation update := MapProperties.update.

  Definition Submap m1 m2 :=
    forall k e, MapsTo k e m1 -> MapsTo k e m2.

  Lemma Submap_in:
    forall {m1 m2}, Submap m1 m2 ->
                    forall k, In k m1 -> In k m2.
  Admitted.

  (* Pull in the library’s facts on Disjoint and Partition. *)
  Lemma Disjoint_alt:
    forall m m', Disjoint m m' <->
                 (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False).
  Admitted.

  Lemma Disjoint_empty_r:
    forall {m}, Disjoint m (Map.empty elt).
  Admitted.

  Lemma Disjoint_sym:
    forall {m1 m2}, Disjoint m1 m2 -> Disjoint m2 m1.
  Admitted.

  Lemma Disjoint_in_nin:
    forall {m1 m2}, Disjoint m1 m2 ->
                    forall k, In k m1 -> ~ In k m2.
  Admitted.

  Lemma Disjoint_mapsto_nin:
    forall {m1 m2}, Disjoint m1 m2 ->
                    forall k e, MapsTo k e m1 -> ~ In k m2.
  Admitted.

  Lemma Disjoint_submap_r:
    forall m1 m2 m3, Disjoint m1 m2 ->
                     Submap m3 m2 -> Disjoint m1 m3.
  Admitted.

  Lemma update_in_iff:
    forall m1 m2 k, In k (update m1 m2) <-> In k m1 \/ In k m2.
  Admitted.

  Lemma update_mapsto_iff:
    forall m1 m2 k e, MapsTo k e (update m1 m2) <->
                      (MapsTo k e m2 \/ (MapsTo k e m1 /\ ~ In k m2)).
  Admitted.

  Lemma disjoint_update_mapsto_iff:
    forall {m1 m2}, Disjoint m1 m2 ->
                    forall k e, MapsTo k e (update m1 m2) <->
                                MapsTo k e m1 \/ MapsTo k e m2.
  Admitted.

  Lemma disjoint_update_comm:
    forall {m1 m2}, Disjoint m1 m2 ->
                    Map.Equal (update m1 m2) (update m2 m1).
  Admitted.

  Lemma update_submap_r:
    forall m1 m2, Submap m2 (update m1 m2).
  Admitted.

  Lemma disjoint_update_submap_l:
    forall {m1 m2}, Disjoint m1 m2 ->
                    Submap m1 (update m1 m2).
  Admitted.

  Lemma Partition_disjoint:
    forall {m m1 m2}, Partition m m1 m2 -> Disjoint m1 m2.
  Admitted.

  Lemma Partition_mapsto_iff:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k e, MapsTo k e m <->
                                  MapsTo k e m1 \/ MapsTo k e m2.
  Admitted.

  Lemma Partition_mapsto_l:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k e, MapsTo k e m1 -> MapsTo k e m.
  Admitted.

  Lemma Partition_mapsto_r:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k e, MapsTo k e m2 -> MapsTo k e m.
  Admitted.

  Lemma Partition_submap_l:
    forall {m m1 m2}, Partition m m1 m2 -> Submap m1 m.
  Admitted.

  Lemma Partition_submap_r:
    forall {m m1 m2}, Partition m m1 m2 -> Submap m2 m.
  Admitted.

  Lemma Partition_in_iff:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k, In k m <-> In k m1 \/ In k m2.
  Admitted.

  Lemma Partition_in_l:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k, In k m1 -> In k m.
  Admitted.

  Lemma Partition_in_r:
    forall {m m1 m2}, Partition m m1 m2 ->
                      forall k, In k m2 -> In k m.
  Admitted.

  Lemma Partition_refl:
    forall m, Partition m m (Map.empty elt).
  Admitted.

  Lemma Partition_sym:
    forall m m1 m2, Partition m m1 m2 -> Partition m m2 m1.
  Admitted.

  Lemma Partition_empty_r:
    forall m m', Partition m m' (Map.empty elt) -> Map.Equal m m'.
  Admitted.

  Lemma Partition_update:
    forall m m1 m2, Partition m m1 m2 -> Map.Equal m (update m1 m2).
  Admitted.

  Lemma disjoint_update_partition:
    forall m1 m2, Disjoint m1 m2 -> Partition (update m1 m2) m1 m2.
  Admitted.

  Lemma Partition_assoc:
    forall m m1 m2 m2a m2b,
      Partition m m1 m2 ->
      Partition m2 m2a m2b ->
      Partition m (update m1 m2a) m2b.
  Admitted.

  Lemma Partition_add_1:
    forall m m1 m2 k v v1,
      Partition m (Map.add k v1 m1) m2 ->
      Partition (Map.add k v m) (Map.add k v m1) m2.
  Admitted.

End XFacts.
End WXFacts_fun.

Module Separation.
  Definition ptr := Z.
  Definition ptr_eq := Z.eq_dec.
  Definition value := Z.
  Implicit Types v: value.

  Module Heap := FMapList.Make Z_as_OT.
  Module HeapF := FMapFacts.WFacts_fun Z_as_OT Heap.
  Module HeapP := FMapFacts.WProperties_fun Z_as_OT Heap.
  Module HeapX := WXFacts_fun Z_as_OT Heap.

  Definition heap := Heap.t value.
  Implicit Types h : heap.
  Definition empty_heap := Heap.empty value.

  Notation heap_Equal := Heap.Equal.

  (* Assertions, aka heap propositions *)
  Definition weak_assertion := heap -> Prop.

  Definition assertion_wf (wa:weak_assertion) :=
    forall h1 h2,
      heap_Equal h1 h2 -> wa h1 -> wa h2.

  Lemma assertion_wf_iff:
    forall wa:weak_assertion,
      forall wawf:assertion_wf wa,
        forall h1 h2,
          heap_Equal h1 h2 -> wa h1 <-> wa h2.
  Proof.
    split; intros; unfold assertion_wf in *.
    - now apply wawf with (h1:=h1).
    - apply wawf with (h1:=h2); [ symmetry | ]; auto.
  Qed.

  Inductive assertion : Type :=
  | Assert : forall wa:weak_assertion,
      forall wawf:assertion_wf wa,
        assertion.
  Hint Constructors assertion.

  Definition asserts : assertion -> heap -> Prop :=
    fun a h =>
      match a with
      | Assert wa _ => wa h
      end.

  Global Instance: Proper (eq ==> heap_Equal ==> iff) asserts.
  Proof.
    intros a1 a2 aeq h1 h2 heq; subst; destruct a2.
    unfold asserts; split; intros.
    - now apply (wawf _ _ heq).
    - symmetry in heq; now apply (wawf _ _ heq).
  Qed.

  Definition assertion_imp : assertion -> assertion -> Prop :=
    fun a1 a2 =>
      forall h, asserts a1 h -> asserts a2 h.

  Definition assertion_iff : assertion -> assertion -> Prop :=
    fun a1 a2 =>
      forall h, asserts a1 h <-> asserts a2 h.

  Infix "===>" := assertion_imp (at level 90) : sep_scope.
  Infix "<===>" := assertion_iff (at level 90) : sep_scope.
  Local Open Scope sep_scope.

  Definition emp : assertion.
    refine (Assert (fun h => heap_Equal h empty_heap) _).
    unfold assertion_wf; intros; now rewrite <- H.
  Defined.

  Definition pointsto : ptr -> value -> assertion.
    intros p v.
    refine (Assert (fun h => heap_Equal h (Heap.add p v empty_heap)) _).
    unfold assertion_wf; intros; now rewrite <- H.
  Defined.
  Infix "|>" := pointsto (no associativity, at level 75) : sep_scope.

  Definition points : ptr -> assertion.
    intros p.
    refine (Assert (fun h => exists v, heap_Equal h (Heap.add p v empty_heap)) _).
    unfold assertion_wf; intros.
    destruct H0; exists x; now rewrite <- H.
  Defined.
  Notation "p |>?" := (points p) (no associativity, at level 75) : sep_scope.

  Definition weak_star : assertion -> assertion -> weak_assertion :=
    fun a1 a2 =>
      fun h =>
        exists h1 h2, HeapP.Partition h h1 h2 /\ asserts a1 h1 /\ asserts a2 h2.

  Definition star : assertion -> assertion -> assertion.
    intros a1 a2.
    refine (Assert (weak_star a1 a2) _).
    unfold assertion_wf; unfold weak_star; intros; destruct_conjs.
    exists H0, H1; rewrite <- H; intuition.
  Defined.
  Infix "**" := star (right associativity, at level 80) : sep_scope.

  Definition heq : heap -> assertion.
    intros h.
    refine (Assert (fun h' => Heap.Equal h h') _).
    unfold assertion_wf; intros; transitivity h1; auto.
  Defined.

  Definition weak_imp : assertion -> assertion -> weak_assertion :=
    fun a1 a2 =>
      fun h => asserts a1 h -> asserts a2 h.

  Definition imp : assertion -> assertion -> assertion.
    intros a1 a2.
    refine (Assert (weak_imp a1 a2) _).
    unfold assertion_wf. unfold weak_imp. intros.
    rewrite H in *. auto.
  Qed.

  Definition weak_magic_wand : assertion -> assertion -> weak_assertion :=
    fun a1 a2 =>
      fun h => forall h', HeapP.Disjoint h h' -> asserts a1 h' ->
                          asserts a2 (HeapP.update h h').

  Definition magic_wand : assertion -> assertion -> assertion.
    intros a1 a2.
    refine (Assert (weak_magic_wand a1 a2) _).
    unfold assertion_wf. unfold weak_magic_wand. intros.
    assert (HeapP.Disjoint h1 h') by (now rewrite H).
    apply (H0 _ H3) in H2.
    assert (heap_Equal (HeapP.update h2 h') (HeapP.update h1 h'))
      by (now rewrite H).
    now rewrite H4.
  Qed.

  Lemma emp_empty_heap:
    asserts emp empty_heap.
  Admitted.

  Lemma emp_equals_iff h:
    asserts emp h <-> heap_Equal h empty_heap.
  Admitted.

  Lemma heq_equals_iff h1 h:
    asserts (heq h1) h <-> heap_Equal h1 h.
  Admitted.

  Lemma pointsto_equals_iff a v h:
    asserts (pointsto a v) h <-> heap_Equal h (Heap.add a v empty_heap).
  Admitted.

  Lemma points_equals_iff a h:
    asserts (points a) h <-> exists v, heap_Equal h (Heap.add a v empty_heap).
  Admitted.

  Lemma star_iff :
    forall a1 a2 h, asserts (a1 ** a2) h <->
                    exists h1 h2, HeapP.Partition h h1 h2
                                  /\ asserts a1 h1 /\ asserts a2 h2.
  Admitted.

  Ltac destruct_star :=
    match goal with
    | [ |- context [ asserts (?a1 ** ?a2) ?h ] ] => rewrite (star_iff a1 a2 h)
    end.

  Ltac destruct_star_in H :=
    match goal with
    | [ H : context [ asserts (?a1 ** ?a2) ?h ] |- _ ] => rewrite (star_iff a1 a2) in H
    end.

  Lemma add_emp_r:
    forall a, a <===> a ** emp.
  Admitted.

  Lemma star_comm:
    forall a1 a2, a1 ** a2 ===> a2 ** a1.
  Admitted.

  Lemma star_assoc :
    forall a1 a2 a3 h, asserts (a1 ** a2 ** a3) h <-> asserts ((a1 ** a2) ** a3) h.
  Admitted.

  Lemma star_imp:
    forall {a1 a2}, a1 ===> a2 -> forall x, a1 ** x ===> a2 ** x.
  Admitted.

  Lemma pointsto_find:
    forall {p v h}, asserts (p |> v) h -> Heap.find p h = Some v.
  Admitted.

  Lemma star_pointsto_find:
    forall {p v a h}, asserts (p |> v ** a) h -> Heap.find p h = Some v.
  Admitted.

  Lemma points_find:
    forall {p h}, asserts (p |>?) h -> exists v, Heap.find p h = Some v.
  Admitted.

  Lemma star_points_find:
    forall {p a h}, asserts (p |>? ** a) h -> exists v, Heap.find p h = Some v.
  Admitted.

  Definition Cmd := heap -> option heap.

  Definition sep_triple (p:assertion) (c:Cmd) (q:assertion) :=
    forall rest h,
      asserts (p ** heq rest) h ->
      exists h', c h = Some h' /\ asserts (q ** heq rest) h'. (* NB stuff about termination *)
  Notation "{{ P }} c {{ Q }}" := (sep_triple P c Q) (at level 90) : sep_scope.

  Lemma consequence:
    forall p p' c q q',
      {{p}} c {{q}} ->
      p' ===> p ->
      q ===> q' ->
      {{p'}} c {{q'}}.
  Proof.
    unfold sep_triple; intros.
    apply star_imp with (x:=heq rest) in H0.
    apply star_imp with (x:=heq rest) in H1.
    apply H0 in H2.
    apply H in H2.
    destruct_conjs.
    apply H1 in H4.
    exists H2; intuition.
  Qed.

  Lemma frame:
    forall p c q r,
      {{p}} c {{q}} ->
      {{p ** r}} c {{q ** r}}.
  Proof.
    unfold sep_triple; intros.
    rewrite <- star_assoc in H0.
    rewrite star_iff in H0.
    destruct_conjs.
    assert (asserts (p ** heq H1) h).
    rewrite star_iff.
    exists H0, H1; intuition.
    unfold asserts; unfold heq; reflexivity.
    apply H in H5.
    destruct_conjs.
    exists H5.
    intuition.
    rewrite <- star_assoc.
    rewrite star_iff in H7; destruct_conjs.
    rewrite star_iff.
    exists H7, H1.
    rewrite heq_equals_iff in H11.
    repeat rewrite H11 in *.
    intuition.
  Qed.

  Inductive expr :=
  | Ev : Z -> expr
  | Ebin : expr -> expr -> (Z -> Z -> Z) -> expr
  | Eread : expr -> expr
  | Ewrite : expr -> expr -> expr.

  Fixpoint estepf (e:expr) (h:heap) : option (expr * heap) :=
    match e with
    | Ebin (Ev v1) (Ev v2) op => Some (Ev (op v1 v2), h)
    | Ebin (Ev v1) e2 op => match estepf e2 h with
                            | Some (e2',h') => Some (Ebin (Ev v1) e2' op, h')
                            | _ => None
                            end
    | Ebin e1 e2 op => match estepf e1 h with
                       | Some (e1',h') => Some (Ebin e1' e2 op, h')
                       | _ => None
                       end
    | Eread (Ev a) => match Heap.find a h with
                      | Some v => Some (Ev v, h)
                      | _ => None
                      end
    | Eread e => match estepf e h with
                 | Some (e',h') => Some (Eread e', h')
                 | _ => None
                 end
    | Ewrite (Ev a) (Ev v) => match Heap.find a h with
                              | Some _ => Some (Ev v, Heap.add a v h)
                              | _ => None
                              end
    | Ewrite (Ev a) e => match estepf e h with
                         | Some (e',h') => Some (Ewrite (Ev a) e', h')
                         | _ => None
                         end
    | Ewrite a e => match estepf a h with
                    | Some (a',h') => Some (Ewrite a' e, h')
                    | _ => None
                    end
    | _ => None
    end.

  Definition ecmd : expr -> Cmd :=
    fun e h =>
      match estepf e h with
      | Some (e', h') => Some h'
      | _ => None
      end.
  Hint Resolve ecmd.

  Lemma ecmd_estepf_iff e h h':
    ecmd e h = Some h' <-> exists e', estepf e h = Some (e', h').
  Proof.
    split; intros.
    unfold ecmd in *; remember (estepf e h) as s; destruct s.
    destruct p; exists e0; inversion H; intuition.
    discriminate.
    unfold ecmd in *; destruct H as [e' H]; rewrite H; auto.
  Qed.

  Lemma readv_tc:
    forall a v,
      {{ a |> v }} ecmd (Eread (Ev a)) {{ a |> v }}.
  Admitted.

  Lemma writev_tc:
    forall a v,
      {{ a |>? }} ecmd (Ewrite (Ev a) (Ev v)) {{ a |> v }}.
  Admitted.

  Lemma reads_tc:
    forall a1 a2 e1,
      {{a1}} ecmd e1 {{a2}} ->
      {{a1}} ecmd (Eread e1) {{a2}}.
  Proof.
    intros a1 a2 e1 H rest h A.
    generalize (H rest h A); intro G; destruct G as [hg [G1 G2]].
    exists hg; split; auto.
    rewrite ecmd_estepf_iff in G1; destruct G1 as [e' G1].
  Admitted.

End Separation.


(** * Notations  *)

Require Export UniMath.Foundations.All.

Notation "A ⇒ B" := (himpl A B) : logic.

Definition hequiv (P Q:hProp) : hProp := ((P ⇒ Q) ∧ (Q ⇒ P))%logic.

Notation "A ⇔ B" := (hequiv A B) (at level 95, no associativity) : logic.

Definition total2_hProp {X : hProp} (Y : X -> hProp) : hProp
  := make_hProp (∑ x, Y x) (isaprop_total2 X Y).

Declare Scope prop.
Delimit Scope prop with prop.

Notation "'∑' x .. y , P" := (total2_hProp (λ x,.. (total2_hProp (λ y, P))..))
  (at level 200, x binder, y binder, right associativity) : prop.
  (* type this in emacs in agda-input method with \sum *)

Notation "'pr11' x" := (pr1 (pr1 x)) (at level 10, left associativity).
Notation "'pr12' x" := (pr1 (pr2 x)) (at level 10, left associativity).
Notation "'pr21' x" := (pr2 (pr1 x)) (at level 10, left associativity).
Notation "'pr22' x" := (pr2 (pr2 x)) (at level 10, left associativity).

Notation "'pr111' x" := (pr1 (pr1 (pr1 x))) (at level 10, left associativity).
Notation "'pr112' x" := (pr1 (pr1 (pr2 x))) (at level 10, left associativity).
Notation "'pr121' x" := (pr1 (pr2 (pr1 x))) (at level 10, left associativity).
Notation "'pr122' x" := (pr1 (pr2 (pr2 x))) (at level 10, left associativity).
Notation "'pr211' x" := (pr2 (pr1 (pr1 x))) (at level 10, left associativity).
Notation "'pr212' x" := (pr2 (pr1 (pr2 x))) (at level 10, left associativity).
Notation "'pr221' x" := (pr2 (pr2 (pr1 x))) (at level 10, left associativity).
Notation "'pr222' x" := (pr2 (pr2 (pr2 x))) (at level 10, left associativity).

(** ** Variants on paths and coconus *)

Definition paths_from {X} (x:X) := coconusfromt X x.
Definition point_to {X} {x:X} : paths_from x -> X := coconusfromtpr1 _ _.
Definition paths_from_path {X} {x:X} (w:paths_from x) := pr2 w.
Definition paths' {X} (x:X) := λ y, y = x.
Definition idpath' {X} (x:X) := idpath x : paths' x x.
Definition paths_to {X} (x:X) := coconustot X x.
Definition point_from {X} {x:X} : paths_to x -> X := coconustotpr1 _ _.
Definition paths_to_path {X} {x:X} (w:paths_to x) := pr2 w.

Lemma iscontr_paths_to {X} (x:X) : iscontr (paths_to x).
Proof. apply iscontrcoconustot. Defined.
Lemma iscontr_paths_from {X} (x:X) : iscontr (paths_from x).
Proof. apply iscontrcoconusfromt. Defined.
Definition paths_to_prop {X} (x:X) :=
  make_hProp (paths_to x) (isapropifcontr (iscontr_paths_to x)).
Definition paths_from_prop {X} (x:X) :=
  make_hProp (paths_from x) (isapropifcontr (iscontr_paths_from x)).

(** ** Squashing *)

Notation squash_fun := hinhfun (only parsing).
Notation squash_fun2 := hinhfun2 (only parsing).
Notation squash_element := hinhpr (only parsing).

Lemma squash_path {X} (x y:X) : squash_element x = squash_element y.
Proof. intros. apply propproperty. Defined.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis
  Require Import boolp reals discrete realseq realsum distr.

Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import GRing.Theory Num.Theory Order.Theory.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Local Notation "← x" := (inl x) (at level 2).
Local Notation "→ x" := (inr x) (at level 2).

(* -------------------------------------------------------------------- *)
Notation IFP := (if _ then _ else _)%pattern.
Notation IFC := (X in if X then _ else _)%pattern.
Notation IFT := (X in if _ then X else _)%pattern.
Notation IFF := (X in if _ then _ else X)%pattern.

(* -------------------------------------------------------------------- *)
Lemma fun2_if {A B C : Type} (f : A -> B -> C) b vT1 vT2 vF1 vF2 :
    f (if b then vT1 else vF1) (if b then vT2 else vF2)
  = if b then f vT1 vT2 else f vF1 vF2.
Proof. by case: b. Qed.

(* -------------------------------------------------------------------- *)
Lemma forallPn {T : finType} (P : pred T) :
  reflect (exists x : T, ~ P x) (~~ [forall x : T, P x]).
Proof. by rewrite negb_forall; apply/'exists_negP. Qed.

(* -------------------------------------------------------------------- *)
Lemma existsPn {T : finType} (P : pred T) :
  reflect (forall x : T, ~ P x) (~~ [exists x : T, P x]).
Proof. by rewrite negb_exists; apply/'forall_negP. Qed.

(* -------------------------------------------------------------------- *)
Section FSplit.
Context {T : Type} (n p : nat).
Context (fn : 'I_n -> T) (fp : 'I_p -> T).

Definition fsplit i :=
  match split i with
  | inl i1 => fn i1
  | inr i2 => fp i2
  end.

Lemma fsplitl (i : 'I_n) : fsplit (lshift p i) = fn i.
Proof.
rewrite /fsplit; case: splitP => j.
+ by move/(@val_inj _ _ [subType of 'I_n]) => ->.
rewrite /lshift /= => iE; have := ltn_ord i.
by rewrite iE -{2}[n]addn0 ltn_add2l ltn0.
Qed.

Lemma fsplitr (i : 'I_p) : fsplit (rshift n i) = fp i.
Proof.
rewrite /fsplit; case: splitP => j; rewrite /rshift /= => jE.
+ by have := ltn_ord j; rewrite -jE -{2}[n]addn0 ltn_add2l ltn0.
+ by move/addnI: jE => /(@val_inj _ _ [subType of 'I_p]) => ->.
Qed.

Definition fsplitlr := (@fsplitl, @fsplitr).
End FSplit.

(* -------------------------------------------------------------------- *)
Section BigFSplit.
Context {T R : Type} (idx : R) (op : Monoid.com_law idx).
Context {n p : nat} (Fn : 'I_n -> R) (Fp : 'I_p -> R).

Lemma big_fsplit :
  \big[op/idx]_(i < n + p) fsplit Fn Fp i =
    op (\big[op/idx]_(i < n) Fn i) (\big[op/idx]_(i < p) Fp i).
Proof.
rewrite big_split_ord; congr (op _ _).
+ by apply/eq_bigr=> /= i _; rewrite fsplitl.
+ by apply/eq_bigr=> /= i _; rewrite fsplitr.
Qed.
End BigFSplit.

(* -------------------------------------------------------------------- *)
Lemma splitl m1 m2 (z : 'I_m1) : split (lshift m2 z) = inl _ z.
Proof. case: splitP => j /=.
+ by move/(can_inj (valKd _)) => -/(_ z) ->.
+ by move/eqP; rewrite ltn_eqF // ltn_addr.
Qed.

Lemma splitr m1 m2 (z : 'I_m2) : split (rshift m1 z) = inr _ z.
Proof. case: splitP => j /= /eqP.
+ by rewrite gtn_eqF // ltn_addr.
+ by rewrite eqn_add2l => /eqP /(can_inj (valKd _)) -/(_ z) ->.
Qed.

Definition splitlr := (splitl, splitr).

(* -------------------------------------------------------------------- *)
Section SplitInd.
Context (m1 m2 : nat) (P : 'I_(m1 + m2) -> Prop).

Hypothesis hl : forall i, P (lshift _ i).
Hypothesis hr : forall i, P (rshift _ i).

Lemma splitW i : P i.
Proof. case: (splitP i) => j eq.
+ suff ->: i = lshift _ j by apply/hl. by apply/val_eqP/eqP.
+ suff ->: i = rshift _ j by apply/hr. by apply/val_eqP/eqP.
Qed.
End SplitInd.

(* --------------------------------------------------------------------- *)
Lemma tnth_cat {T : Type} {n m} (t1 : n.-tuple T) (t2 : m.-tuple T) i :
  tnth [tuple of t1 ++ t2] i =
    match split i with
    | inl i => tnth t1 i
    | inr i => tnth t2 i
    end.
Proof.
elim/splitW: i=> i; rewrite splitlr.
+ rewrite (tnth_nth (tnth t1 i)) nth_cat size_tuple /=.
  by rewrite ltn_ord -tnth_nth.
+ rewrite (tnth_nth (tnth t2 i)) nth_cat size_tuple /=.
  by rewrite ltnNge leq_addr /= addKn -tnth_nth.
Qed.

Lemma tnth_catl {T : Type} {n m} (t1 : n.-tuple T) (t2 : m.-tuple T) i :
  tnth [tuple of t1 ++ t2] (lshift _ i) = tnth t1 i.
Proof. by rewrite tnth_cat splitl. Qed.

Lemma tnth_catr {T : Type} {n m} (t1 : n.-tuple T) (t2 : m.-tuple T) i :
  tnth [tuple of t1 ++ t2] (rshift _ i) = tnth t2 i.
Proof. by rewrite tnth_cat splitr. Qed.

Definition tnth_catlr := (@tnth_catl, @tnth_catr).

(* -------------------------------------------------------------------- *)
Section Extrema.
Context {R : realDomainType} {I : finType} (P : pred I) (F : I -> R).

Hypothesis hP : (exists i, P i).

Local Lemma arg_min_proof :
  exists i, P i && [forall (j | P j), (F i <= F j)%R].
Proof.
pose s := [seq i <- enum I | P i]; pose i0 := xchoose hP.
suff: exists2 i, i \in s & (forall j, j \in s -> (F i <= F j)%R).
+ case=> i; rewrite mem_filter => /andP[Pi _] mini; exists i.
  apply/andP; split=> //; apply/forall_inP => j Pj.
  by apply/mini; rewrite mem_filter Pj mem_enum.
have: s != [::]; first rewrite -has_filter.
+ by apply/hasP; exists i0; [rewrite mem_enum | apply/xchooseP].
elim: s => {i0} // i s ih _; case: (s =P [::]) => [{ih}->|].
+ by exists i => [|j]; rewrite mem_seq1 => // /eqP ->.
move/eqP=> /ih[{ih} j j_in_s ih]; case: (lerP (F i) (F j)).
+ move=> le_FiFj; exists i; first by rewrite mem_head.
  move=> k; rewrite in_cons => /orP[/eqP->//|/ih].
  by apply/(le_trans le_FiFj).
+ move/ltW=> le_FjFi; exists j; first by rewrite mem_behead.
  by move=> k; rewrite in_cons => /orP[/eqP->|/ih].
Qed.

Definition arg_minr := nosimpl (xchoose arg_min_proof).

CoInductive extremum_spec : I -> Type :=
  ExtremumSpec i of P i & (forall j, P j -> (F i <= F j)%R)
    : extremum_spec i.

Lemma arg_minrP : extremum_spec arg_minr.
Proof.
by have /andP[Px /forall_inP Plex] := xchooseP arg_min_proof.
Qed.
End Extrema.

(* -------------------------------------------------------------------- *)
Section SpanP.
Context {K : fieldType} {vT: vectType K}.

Lemma spanP {n} (X : n.-tuple vT) (x : vT) :
  reflect
    (exists μ, x = \sum_i μ i *: tnth X i)
    (x \in <<X>>%VS).
Proof. apply: (iffP idP) => /=.
+ move/coord_span => ->; exists (fun i => coord X i x).
  by apply/eq_bigr=> /= i _; rewrite (tnth_nth 0).
+ case=> μ ->; rewrite span_def big_tuple; apply/memv_sumP => /=.
  exists (fun i => μ i *: tnth X i) => // i _.
  by apply/vlineP; exists (μ i).
Qed.
End SpanP.

(* -------------------------------------------------------------------- *)
Section FreeSub.
Context {K : fieldType} {vT : vectType K}.

Lemma sub_free (X Y : seq vT) :
  {subset X <= Y} -> free Y -> uniq X -> free X.
Proof.
move=> leXY frY uqX; have /permPl peq := perm_filterC (mem X) Y.
have := frY; rewrite -(perm_free peq) => /catl_free.
rewrite -(@perm_free _ _ X) //; apply/uniq_perm => // [|x].
+ by rewrite filter_uniq // free_uniq.
+ by rewrite mem_filter andbC; apply/esym/andb_idl => /leXY.
Qed.
End FreeSub.

(* -------------------------------------------------------------------- *)
Section PR.
Context {R : realType}.

(* -------------------------------------------------------------------- *)
Lemma pr_finE {T : finType} (d : {distr T / R}) (E : pred T) :
  \P_[d] E = \sum_i (E i)%:R * d i :> R.
Proof.
rewrite /pr psum_fin; apply/eq_bigr => t _.
by rewrite ger0_norm // mulr_ge0 // ler0n.
Qed.

(* -------------------------------------------------------------------- *)
Lemma eqr_in_pr {T : choiceType} (mu1 mu2 : {distr T / R}) E :
  {in E, mu1 =1 mu2} -> \P_[mu1] E = \P_[mu2] E.
Proof.
move=> h; apply/eq_psum=> x; case/boolP: (E x) => hE.
+ by rewrite !mul1r h. + by rewrite !mul0r.
Qed.

(* -------------------------------------------------------------------- *)
Lemma eqr_pr {T : choiceType} (mu1 mu2 : {distr T / R}) E :
  mu1 =1 mu2 -> \P_[mu1] E = \P_[mu2] E.
Proof. by move=> eq; apply/eqr_in_pr. Qed.
End PR.

(* -------------------------------------------------------------------- *)
Lemma perm_cat2lE {T : eqType} (s1 s2 s3 : seq T) :
  perm_eq s2 s3 -> perm_eql (s1 ++ s2) (s1 ++ s3).
Proof. by move=> h; apply/permPl; rewrite perm_cat2l. Qed.

(* -------------------------------------------------------------------- *)
Lemma perm_cat2rE {T : eqType} (s1 s2 s3 : seq T) :
  perm_eq s2 s3 -> perm_eql (s2 ++ s1) (s3 ++ s1).
Proof. by move=> h; apply/permPl; rewrite perm_cat2r. Qed.

(* -------------------------------------------------------------------- *)
Lemma perm_cat {T : eqType} (s1 s2 t1 t2 : seq T) :
  perm_eq s1 t1 -> perm_eq s2 t2 -> perm_eq (s1 ++ s2) (t1 ++ t2).
Proof.
by move=> h1 h2; rewrite (perm_cat2rE _ h1) perm_cat2l.
Qed.

(* -------------------------------------------------------------------- *)
Lemma enum_bool_perm : perm_eq (enum {: bool}) [:: true; false].
Proof. by rewrite enumT Finite.EnumDef.enumDef. Qed.

(* -------------------------------------------------------------------- *)
Lemma enum_sum_perm {T U : finType} :
  perm_eq
    (enum {: T + U})
    ([seq ← t | t : T] ++ [seq → u | u : U]).
Proof.
have inj_inl: injective inl by move=> T1 T2 x y [].
have inj_inr: injective inr by move=> T1 T2 x y [].
apply/uniq_perm; rewrite ?enum_uniq //.
+ rewrite cat_uniq ?map_inj_uniq -?enumT ?enum_uniq ?andbT //=.
  by apply/hasPn=> /= x /mapP[u _ ->]; apply/mapP; case.
move=> x; apply/esym; rewrite mem_cat mem_enum [in RHS]/in_mem /=.
by apply/orP; case: x => [t|u]; [left|right]; apply/map_f; rewrite enumT.
Qed.

(* -------------------------------------------------------------------- *)
Lemma enum_option_perm {T : finType} :
  perm_eq
    (enum {: option T})
    (None :: [seq Some t | t : T]).
Proof.
apply/uniq_perm; rewrite ?enum_uniq //=.
+ apply/andP; split.
  * by apply/negP=> /mapP[].
  * by rewrite map_inj_uniq ?enum_uniq // => x y [].
move=> x; apply/esym; rewrite mem_enum [in RHS]/in_mem /=.
by case: x => [x|] //=; apply/map_f; rewrite enumT.
Qed.

(* -------------------------------------------------------------------- *)
Section BigOp.
Context {R : Type} (idx : R) (op : Monoid.com_law idx).

Local Notation "1" := idx.
Local Notation "'*%M'" := op (at level 0).
Local Notation "x * y" := (op x y).

Lemma big_sum {I J : finType} (P : pred (I + J)) (F : I + J -> R) :
  \big[op/1]_(ij | P ij) F ij =
      (\big[op/1]_(i | P (← i)) F (← i))
    * (\big[op/1]_(j | P (→ j)) F (→ j)).
Proof.
rewrite /index_enum -!enumT (perm_big _ enum_sum_perm).
by rewrite big_cat !big_map.
Qed.

Lemma big_option {I : finType} (P : pred (option I)) (F : option I -> R) :
  \big[op/1]_(ij | P ij) F ij =
      (if P None then F None else 1)
    * (\big[op/1]_(i | P (Some i)) F (Some i)).
Proof.
rewrite /index_enum -!enumT (perm_big _ enum_option_perm) big_cons.
by rewrite -[IFF](Monoid.mul1m op) -fun2_if if_same big_map.
Qed.
End BigOp.

(* -------------------------------------------------------------------- *)
Section Uniq.
Context {T : eqType} (x0 : T).

Implicit Types (s : seq T).

Lemma uniqPn s :
  reflect
    (exists i j, [/\ i < j, j < size s & nth x0 s i = nth x0 s j])%N
    (~~ uniq s).
Proof.
apply: (iffP idP) => [|[i [j [ltij ltjs]]]]; last first.
  by apply: contra_eqN => Us; rewrite nth_uniq ?ltn_eqF // (ltn_trans ltij).
elim: s => // x s IHs /nandP[/negbNE | /IHs[i [j]]]; last by exists i.+1, j.+1.
by exists 0%N, (index x s).+1; rewrite !ltnS index_mem /= nth_index.
Qed.

Lemma uniqP s :
  reflect
    {in [pred i | (i < size s)%N] &, injective (nth x0 s)}
    (uniq s).
Proof.
apply: (iffP idP) => [????? /eqP|]; first by rewrite nth_uniq // => /eqP.
move=> nth_inj; apply/uniqPn => -[i [j [ltij ltjs /nth_inj ]]].
by move=> /(_ (ltn_trans ltij ltjs)) /(_ ltjs) eq_ij; rewrite eq_ij ltnn in ltij.
Qed.
End Uniq.

(* -------------------------------------------------------------------- *)
Section Ord.
Context (n : nat).

Definition double_ord_proof x : (x < n)%N -> (x.*2 < n.*2)%N.
Proof. by rewrite ltn_double. Qed.

Definition inc_double_ord_proof x : (x < n)%N -> (x.*2.+1 < n.*2)%N.
Proof. by rewrite ltn_Sdouble. Qed.

Definition double_ord (x : 'I_n) := Ordinal (double_ord_proof (ltn_ord x)).
Definition inc_double_ord (x : 'I_n) := Ordinal (inc_double_ord_proof (ltn_ord x)).
End Ord.

(* -------------------------------------------------------------------- *)
Section Matrix.
Context (R : ringType) (m n : nat).

Lemma mulmx_sum_rowE (u : 'rV[R]_m) (A : 'M[R]_(m, n)) i :
  (u *m A) 0 i = \sum_j u 0 j * A j i.
Proof.
by rewrite mulmx_sum_row summxE; apply/eq_bigr => j _; rewrite !mxE.
Qed.
End Matrix.

(* -------------------------------------------------------------------- *)
Lemma head_rot_index {T : eqType} (s : seq T) x :
  x \in s -> uniq s -> next s x = head x (rot (index x s).+1 s).
Proof.
move/path.splitP=> [p1 p2]; rewrite -cats1 -catA => uq.
rewrite !index_cat mem_seq1 /= !eqxx addn0.
move: (uq); rewrite uniq_catC -catA => /=.
case/andP; rewrite mem_cat negb_or => /andP[_ /negbTE ->] _.
rewrite rotS; first by rewrite size_cat /= addnS ltnS leq_addr.
rewrite rot_size_cat /= rot1_cons -nth0.
rewrite -(next_rot (size p1)); first by rewrite -cat1s.
rewrite rot_size_cat cat_cons next_nth mem_head.
by case: (p2 ++ p1) => //=; rewrite eqxx.
Qed.

Lemma next_head {T : eqType} (s : seq T) x : next (x :: s) x = head x s.
Proof. by rewrite next_nth mem_head /= eqxx nth0. Qed.

(* -------------------------------------------------------------------- *)
Section CompMonoid.
Context {T: Type}.

Notation comp := (@comp T T T).

Definition compA : associative comp.
Proof. done. Qed.

Definition compf1 : left_id idfun comp.
Proof. done. Qed.

Definition comp1f : right_id idfun comp.
Proof. done. Qed.

Canonical comp_monoid := Monoid.Law compA compf1 comp1f.
End CompMonoid.

(* -------------------------------------------------------------------- *)
Lemma eq_bigcomp {I T : Type} (P : pred I) (F1 F2 : I -> T -> T) r :
     (forall x, P x -> F1 x =1 F2 x)
  ->    \big[comp/idfun]_(x <- r | P x) F1 x
     =1 \big[comp/idfun]_(x <- r | P x) F2 x.
Proof.
move=> eqF; elim: r => [|x r ih] v; first by rewrite !big_nil.
rewrite !big_cons; case: ifP => //= Px.
by rewrite ih; apply/eqF.
Qed.

Lemma homo_comp (f g : nat -> nat) :
     {homo f : m n / (m < n)%N}
  -> {homo g : m n / (m < n)%N}
  -> {homo f \o g : m n / (m < n)%N}.
Proof. by move=> hf hg m n /= ltmn; apply/hf/hg. Qed.

Lemma homo_bigcomp {I : Type} (P : pred I) (F : I -> nat -> nat) r :
     (forall x, P x -> {homo F x : m n / (m < n)%N})
  -> {homo \big[comp/idfun]_(x <- r | P x) F x : m n / (m < n)%N}.
Proof.
move=> h; elim: r => [|x r ih]; first by rewrite !big_nil.
move=> m n lt_mn; rewrite big_cons; case: ifPn => [/h Px|_].
by apply/Px/ih. by apply/ih.
Qed.

Lemma homo_geidfun (f : nat -> nat) :
  {homo f : m n / (m < n)%N} -> forall n, (n <= f n)%N.
Proof.
by move=> h; elim => // n ih; apply/(leq_ltn_trans ih)/h.
Qed.

Lemma homo_leq_mono (f : nat -> nat) :
   {homo f : m n / (m <  n)%N} ->
   {mono f : m n / (m <= n)%N}.
Proof.
move=> mf m n /=; case: (leqP m n); last first.
+ by move/mf; rewrite leqNgt ltnS => /negbTE.
by rewrite leq_eqVlt => /orP[/eqP->|/mf/ltnW //]; rewrite leqnn.
Qed.

Lemma homo_ltn_mono (f : nat -> nat) :
   {homo f : m n / (m < n)%N} ->
   {mono f : m n / (m < n)%N}.
Proof.
move=> h x y; apply/idP/idP; [apply/contraLR | by apply/h].
by rewrite -!leqNgt leq_eqVlt => /orP[/eqP->//|/h/ltnW].
Qed.

(* -------------------------------------------------------------------- *)
Lemma pr_drestr {R : realType} {T : choiceType} (mu : {distr T / R}) D E :
  \P_[drestr D mu] E = \P_[mu] [predI D & E].
Proof.
rewrite /pr; apply/eq_psum => x /=; rewrite drestrE /in_mem /=.
by case: (D x); case: (E x); rewrite !Monoid.simpm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_option {R : realType} {T : choiceType} (S : option T -> R) :
  summable (fun x => S (Some x)) <-> summable S.
Proof. split.
+ case/summable_seqP => M ge0_M leM; apply/summable_seqP => /=.
  exists (M + `|S None|); first by rewrite addr_ge0.
  move=> J uqJ; rewrite (bigID isSome) ler_add //=.
  - apply/(le_trans _ (leM (pmap idfun J) _)); last first.
    * by apply/(pmap_uniq (g := some)) => // -[].
    rewrite -(big_map _ predT (fun x => `|S x|)) pmapS_filter.
    by rewrite map_id /= big_filter.
  - case/boolP: (None \in J) => NoneJ; last first.
    * rewrite big_seq_cond big_pred0 //= => x; rewrite andbC.
      by case: x => //; rewrite (negbTE NoneJ).
    rewrite (perm_big _ (perm_to_rem NoneJ)) big_cons /=.
    rewrite big_seq_cond big1 ?addr0 // => x.
    by rewrite mem_rem_uniq //= !inE andbAC; case: x.
+ case/summable_seqP => /= M ge0_M leM; apply/summable_seqP.
  exists M => // J uqJ; apply/(le_trans _ (leM (map some J) _)).
  - by rewrite big_map.
  - by rewrite map_inj_uniq // => x y [].
Qed.

(* -------------------------------------------------------------------- *)
Lemma psum_option {R : realType} {T : choiceType} (S : option T -> R) :
  summable S -> psum S = psum (S \o some) + `|S None|.
Proof.
move=> hS; have hSo: summable (S \o some) by apply/summable_option.
rewrite (psumID isSome) //=; congr +%R; last first.
+ rewrite (psum_finseq (r := [:: None])) //; last first.
  * by rewrite big_seq1 mul1r.
  by case=> // a; rewrite !inE /= mul0r eqxx.
rewrite (reindex_psum_onto (h := some) (h' := idfun) (P := isSome)) //=.
+ by case=> //; rewrite mul0r eqxx.
+ by case.
+ by apply/eq_psum=> x; rewrite mul1r.
Qed.

(* -------------------------------------------------------------------- *)
Lemma dinsupp_dlim {R : realType } {T: choiceType} (μ : nat -> {distr T / R}) x :
  x \in dinsupp (dlim μ) ->
    exists K, forall n, (K <= n)%N -> x \in dinsupp (μ n).
Proof.
move/dinsuppP; rewrite dlimE; case: nlimP => // -[] // l cvg.
move/eqP => /= nz_l; have gt0_absl: 0 < `|l| by rewrite normr_gt0.
case/ncvg_abs/(_ (NFin _ gt0_absl)): cvg=> K cvg; exists K => n.
move/cvg; rewrite inE ltr_distl => /andP[h _]; apply/dinsuppP.
by apply/eqP; rewrite -normr_gt0 (le_lt_trans _ h) ?subrr.
Qed.

(* -------------------------------------------------------------------- *)
Lemma homoS_lt (f : nat -> nat) :
   (forall x, (f x < f x.+1)%N) -> {homo f : x y / (x < y)%N}.
Proof.
move=> homo x y lt_xy; rewrite -(subnK lt_xy).
elim: (y - _)%N => [|n ih]; first by apply/homo.
by rewrite addSn (leq_trans ih) // 1?ltnW.
Qed.

(* -------------------------------------------------------------------- *)
Lemma homoS_ler {T : numDomainType} (f : nat -> T) :
  (forall x, f x <= f x.+1) -> {homo f : x y / (x <= y)%N >-> x <= y}.
Proof.
move=> homo x y lt_xy; rewrite -(subnK lt_xy).
by elim: (y - _)%N => // n ih; rewrite addSn (le_trans ih (homo _)).
Qed.

(* -------------------------------------------------------------------- *)
Lemma natpred_finiteN (E : pred nat) :
     (forall s : seq nat, ~ {subset E <= s})
  -> { σ : nat -> nat |
        {homo σ : x y / (x < y)%N} & forall n, E (σ n)}.
Proof.
move=> finNE; have h s : exists n, (n > \max_(x <- s) x)%N && E n.
+ set N := \max_(x <- s) x; pose r := iota 0 N.+1 ++ s.
  apply: contra_notP (finNE r) => /asboolPn /forallp_asboolPn h x.
  move=> xE; rewrite mem_cat; have /negP := h x.
  rewrite negb_and -leqNgt mem_iota /= add0n ltnS.
  by rewrite /in_mem /= in xE; rewrite xE orbF => ->.
pose ω s : nat := xchoose (h s).
pose σ := fix σ n := if n is n.+1 then ω (σ n) :: σ n else [::].
exists (fun n => head 0%N (σ n.+1)); last first.
+ by move=> n /=; have := xchooseP (h (σ n)) => /andP[].
apply/homoS_lt => /= nl; set r := _ :: _.
have := xchooseP (h r) => /andP[].
by rewrite {1}big_cons gtn_max => /andP[].
Qed.


Require Import HoTT.
Require Export HoTT.
Require Import FunextAxiom.

(*
Lemma 13 in paper
*)
Definition apTransport (A B : Type0) (f g : A -> B) (e : f = g) (x y : A) (p : x = y) :
  transport (fun h => h x = h y) e (ap f p) = ap g p :=
match e with
  idpath => 1
end.

(*
Definition 6 in paper
*)
Definition fPath {A B : Type0} {f g : A -> B} (e : f = g) (x : A) : f x = g x :=
match e with
  idpath => 1
end.

(*
Lemma 14 in paper
*)
Definition funTransport (A B : Type0) (f g : A -> B) (e : f = g) (x y : A) (p : f x = f y) :
  transport (fun h => h x = h y) e p = (fPath e x)^ @ p @ (fPath e y) :=
match e with
  idpath => (concat_p1 p)^ @ (ap (fun q => q @ 1) (concat_1p p))^
end.

Ltac reduceTransport :=
  rewrite @HoTT.Types.Paths.transport_paths_FlFr ;
  rewrite ap_compose.

(*
Colimits as higher inductive type
*)
Module Export Colims.

Private Inductive colim
  (F : nat -> Type)
  (f : forall (n : nat), F n -> F(S n)) : Type :=
| inc : forall (n : nat), F n -> colim F f.

Axiom com :
  forall
    (F : nat -> Type)
    (f : forall (n : nat), F n -> F(S n))
    (n : nat)
    (x : F n),
  inc F f n x = inc F f (S n) (f n x).

(*
Recursion rule for colimit using Licata's trick
*)
Fixpoint colim_rec
  (P : Type)
  (F : nat -> Type)
  (f : forall (n : nat), F n -> F(S n))
  (Pi : forall (n : nat), F n -> P)
  (Pc : forall (n : nat) (x : F n), Pi n x = Pi (S n) (f n x))
  (x : colim F f)
  {struct x}
  : P
  :=
    (match x return _ -> P with
      | inc n x => fun _ => Pi n x
    end) Pc.

Axiom colim_rec_beta_com : forall
  (P : Type)
  (F : nat -> Type)
  (f : forall (n : nat), F n -> F(S n))
  (Pi : forall (n : nat), F n -> P)
  (Pc : forall (n : nat) (x : F n), Pi n x = Pi (S n) (f n x))
  (n : nat)
  (x : F n)
  , ap (colim_rec P F f Pi Pc) (com F f n x) = Pc n x.

(*
Induction rule for colimit using Licata's trick
*)
Fixpoint colim_ind
  (F : nat -> Type)
  (f : forall (n : nat), F n -> F(S n))
  (P : colim F f -> Type)
  (Pi : forall (n : nat), forall (x : F n), P (inc F f n x))
  (Pc : forall (n : nat) (x : F n), (com F f n x) # Pi n x = Pi (S n) (f n x))
  (x : colim F f)
  {struct x}
  : P x
  :=
    (match x return _ -> P x with
      | inc n x => fun _ => Pi n x
    end) Pc.

Axiom colim_ind_beta_com : forall
  (F : nat -> Type)
  (f : forall (n : nat), F n -> F(S n))
  (P : colim F f -> Type)
  (Pi : forall (n : nat), forall (x : F n), P (inc F f n x))
  (Pc : forall (n : nat) (x : F n), (com F f n x) # Pi n x = Pi (S n) (f n x))
  (n : nat)
  (x : F n)
  , apD (colim_ind F f P Pi Pc) (com F f n x) = Pc n x.
End Colims.

(*
The colimit of F(X) = A is A.
Lemma 10 in paper.
*)
Section ColimConst.

(*
colim A id -> A
Defined by F(n) -> A as id.
*)
Definition CC_A : forall (A : Type),
  colim (fun (_ : nat) => A) (fun (_ : nat) => idmap) -> A.
Proof.
intro A.
refine (colim_rec _ _ _ _ _).
 Unshelve.
 Focus 2.
 intro n.
 apply idmap.

 intros.
 reflexivity.
Defined.

(*
A -> colim A id
Defined by inc 0
*)
Definition A_CC (A : Type) (a : A) : colim (fun (_ : nat) => A) (fun (_ : nat) => idmap) :=
  inc (fun _ : nat => A) (fun n : nat => idmap) 1 a.

Definition iso_CC_A (A : Type) (x : A) :
  CC_A A (A_CC A x) = x := reflexivity x.

Definition iso_A_CC : forall (A : Type) (x : colim (fun (_ : nat) => A) (fun (_ : nat) => idmap)),
  x = A_CC A (CC_A A x).
Proof.
intro A.
refine (colim_ind _ _ _ _ _).
 Unshelve.
 Focus 2.
 intros.
 induction n.
   apply com.
   apply ((com (fun _ : nat => A) (fun _ : nat => idmap) n x)^ @ IHn).

 intros.
 reduceTransport.
 rewrite ap_idmap.
 rewrite colim_rec_beta_com.
 rewrite concat_p1.
 induction n ; cbn.
 - reflexivity.
 - rewrite IHn.
   reflexivity.
Defined.

End ColimConst.

(*
Colimits commute with sums.
Lemma 11 in paper.
*)
Section ColimSum.

(*
Sum of two functors.
*)
Definition Sum (G1 G2 : nat -> Type) (n : nat) : Type
  := sum (G1 n) (G2 n).

(*
The sum is a functor.
*)
Definition SMap
  (G1 G2 : nat -> Type)
  (g1 : forall (n : nat), G1 n -> G1 (S n))
  (g2 : forall (n : nat), G2 n -> G2 (S n))
  (n : nat)
  (x : Sum G1 G2 n)
  : Sum G1 G2 (S n) :=
match x with
  | inl x => inl (g1 n x)
  | inr y => inr (g2 n y)
end.

(*
colim (G1 + G2) -> colim G1 + colim G2
Defined by
  G1 n + G2 n
  For x : G1 n it is inl(inc n x)
  For y : G2 n it is inr(inc n y)
*)
Definition colim_S :
  forall  (G1 G2 : nat -> Type)
          (g1 : forall (n : nat), G1 n -> G1 (S n))
          (g2 : forall (n : nat), G2 n -> G2 (S n)),
  colim (Sum G1 G2) (SMap G1 G2 g1 g2)
  ->
  sum
    (colim G1 g1)
    (colim G2 g2).
Proof.
intros G1 G2 g1 g2.
refine (colim_rec _ _ _ _ _).
Unshelve.
  Focus 2.
  compute.
  intros n i.
  destruct i as [x | y].
    Focus 1.
    left.
    apply (inc G1 g1 n x).

    right.
    apply (inc G2 g2 n y).

  intros n i.
  destruct i as [x | y].
    apply (ap inl (com G1 g1 n x)).

    apply (ap inr (com G2 g2 n y)).
Defined.

(*
colim (G1 F) + colim (G2 F) -> colim (G1 F + G2 F)
Defined by
  For x : G1(F n) it is inc n (inl x)
  For y : G2(F n) it is inc n (inr x)
*)
Definition S_colim :
  forall  (G1 G2 : nat -> Type)
          (g1 : forall (n : nat), G1 n -> G1 (S n))
          (g2 : forall (n : nat), G2 n -> G2 (S n)),
  sum
    (colim G1 g1)
    (colim G2 g2)
  ->
  colim (Sum G1 G2) (SMap G1 G2 g1 g2).
Proof.
intros G1 G2 g1 g2 i.
destruct i as [x | y].
refine (colim_rec _ _ _ _ _ x).
Unshelve.
  Focus 3.
  intros n a.
  apply (inc (Sum G1 G2) (SMap G1 G2 g1 g2) n).
  left.
  apply a.

  intros n a.
  apply (com (Sum G1 G2) (SMap G1 G2 g1 g2) n (inl a)).

refine (colim_rec _ _ _ _ _ y).
Unshelve.
  Focus 2.
  intros n b.
  apply (inc (Sum G1 G2) (SMap G1 G2 g1 g2) n).
  right.
  apply b.

  cbn.
  intros n b.
  apply (com (Sum G1 G2) (SMap G1 G2 g1 g2) n (inr b)).
Defined.

Theorem S_iso_1 :
  forall  (G1 G2 : nat -> Type)
          (g1 : forall (n : nat), G1 n -> G1 (S n))
          (g2 : forall (n : nat), G2 n -> G2 (S n))
          (i : sum
              (colim G1 g1)
              (colim G2 g2)),
  colim_S G1 G2 g1 g2 (S_colim G1 G2 g1 g2 i) = i.
Proof.
intros G1 G2 g1 g2 i.
destruct i as [x| y].
 Focus 1.
 refine (colim_ind _ _ _ _ _ x).
  Unshelve.
  Focus 2.
  intro z.
  apply
   (colim_S G1 G2 g1 g2 (S_colim G1 G2 g1 g2 (inl z)) = inl z).

  Focus 2.
  intros n a.
  reflexivity.

  intros n a.
  reduceTransport.
  rewrite colim_rec_beta_com.
  rewrite colim_rec_beta_com.
  rewrite concat_p1.
  apply concat_Vp.

 refine (colim_ind _ _ _ _ _ y).
  Unshelve.
  Focus 2.
  intro z.
  apply
   (colim_S G1 G2 g1 g2 (S_colim G1 G2 g1 g2 (inr z)) = inr z).

  Focus 2.
  intros n a.
  reflexivity.

  intros n a.
  reduceTransport.
  rewrite colim_rec_beta_com.
  rewrite colim_rec_beta_com.
  rewrite concat_p1.
  apply concat_Vp.
Qed.

Theorem S_iso_2 :
  forall  (G1 G2 : nat -> Type)
          (g1 : forall (n : nat), G1 n -> G1 (S n))
          (g2 : forall (n : nat), G2 n -> G2 (S n))
          (i : colim (Sum G1 G2) (SMap G1 G2 g1 g2)),
  i = S_colim G1 G2 g1 g2 (colim_S G1 G2 g1 g2 i).
Proof.
intros G1 G2 g1 g2 i.
refine (colim_ind _ _ _ _ _ i).
 Unshelve.
 Focus 2.
 intro x.
 apply (x = S_colim G1 G2 g1 g2 (colim_S G1 G2 g1 g2 x)).

 Focus 2.
 intros.
 destruct x; reflexivity.

 intros.
 destruct x; cbn; reduceTransport; rewrite ap_idmap; rewrite concat_p1; rewrite colim_rec_beta_com.
  Focus 1.
  rewrite <- (ap_compose inl).
  rewrite colim_rec_beta_com.
  apply concat_Vp.

  rewrite <- (ap_compose inr).
  rewrite colim_rec_beta_com.
  apply concat_Vp.

Qed.

End ColimSum.

(*
Coequalizers as a higher inductive type
*)
Module Export Coeq.

Private Inductive coeq
  (A B : Type)
  (f g : A -> B) : Type :=
| inC : B -> coeq A B f g.

Axiom glue :
  forall
    (A B : Type)
    (f g : A -> B)
    (x : A),
  inC A B f g (f x) = inC A B f g (g x).

(*
Recursion rule for coequalizer using Licata's trick
*)
Fixpoint coeq_rec
  (P : Type)
  (A B : Type)
  (f g : A -> B)
  (Pi : B -> P)
  (Pg : forall (x : A), Pi (f x) = Pi (g x))
  (x : coeq A B f g)
  {struct x}
  : P
  :=
    (match x return _ -> P with
      | inC x => fun _ => Pi x
    end) Pg.

Axiom coeq_rec_beta_glue : forall
  (P : Type)
  (A B : Type)
  (f g : A -> B)
  (Pi : B -> P)
  (Pg : forall (x : A), Pi (f x) = Pi (g x))
  (x : A)
  , ap (coeq_rec P A B f g Pi Pg) (glue A B f g x) = Pg x.

(*
Induction rule for colimit using Licata's trick
*)
Fixpoint coeq_ind
  (A B : Type)
  (f g : A -> B)
  (P : coeq A B f g -> Type)
  (Pi : forall (x : B), P (inC A B f g x))
  (Pg : forall (x : A), (glue A B f g x) # Pi (f x) = Pi (g x))
  (x : coeq A B f g)
  {struct x}
  : P x
  :=
    (match x return _ -> P x with
      | inC x => fun _ => Pi x
    end) Pg.

Axiom coeq_ind_beta_glue : forall
  (A B : Type)
  (f g : A -> B)
  (P : coeq A B f g -> Type)
  (Pi : forall (x : B), P (inC A B f g x))
  (Pg : forall (x : A), (glue A B f g x) # Pi (f x) = Pi (g x))
  (x : A)
  , apD (coeq_ind A B f g P Pi Pg) (glue A B f g x) = Pg x.
End Coeq.

(*
Colimits as coequalizers of sums
*)
Module Export ColimAsCoeq.

Parameter F : nat -> Type0.
Parameter f : forall (n : nat), F n -> F(n.+1).

Definition C1 : Type0 := sigT F.

Definition g1 : C1 -> C1 := idmap.

Definition g2 (x : C1) : C1 :=
match x with
  existT n y => existT F (n.+1) (f n y)
end.

Definition C : Type0 := coeq C1 C1 g1 g2.
Definition H : Type0 := colim F f.

Definition CToH : C -> H.
Proof.
refine (coeq_rec _ _ _ _ _ _ _).
 Unshelve.
 Focus 2.
 induction 1.
 apply (inc F f proj1_sig proj2_sig).

 intro x.
 induction x.
 apply com.
Defined.

Definition HToC : H -> C.
Proof.
refine (colim_rec _ _ _ _ _).
 Unshelve.
 Focus 2.
 intros.
 apply (inC C1 C1 g1 g2 (n;H0)).

 intros.
 cbn.
 apply (glue C1 C1 g1 g2).
Defined.

Theorem CToHEq :
  forall (x : C), HToC(CToH x) = x.
Proof.
refine (coeq_ind _ _ _ _ _ _ _).
 Unshelve.
 Focus 2.
 intros.
 reflexivity.

 intros.
 induction x.
 reduceTransport.
 rewrite ap_idmap.
 rewrite concat_p1.
 rewrite coeq_rec_beta_glue.
 rewrite colim_rec_beta_com.
 apply concat_Vp.
Defined.

Theorem HToCEq :
  forall (x : H), CToH(HToC x) = x.
Proof.
refine (colim_ind _ _ _ _ _).
 Unshelve.
 Focus 2.
 intros.
 reflexivity.

 intros.
 reduceTransport.
 rewrite ap_idmap.
 rewrite concat_p1.
 rewrite colim_rec_beta_com.
 rewrite (coeq_rec_beta_glue H C1 C1 g1 g2).
 apply concat_Vp.
Defined.

End ColimAsCoeq.


Require Import Arith.
Require Import NPeano.
Require Import Omega.
Require Import List.
Require Import Coq.Numbers.Natural.Abstract.NDiv.
Import ListNotations.
Require Import Sorting.Permutation.

Require Import Util.
Require Import Net.
Require Import VerdiTactics.
Require Import Raft.

Section OneLeaderPerTerm.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition one_leader_per_term (net : network) :=
    forall h h',
      currentTerm (nwState net h) = currentTerm (nwState net h') ->
      type (nwState net h) = Leader ->
      type (nwState net h') = Leader ->
      h = h'.

  Lemma plus_gt_0 :
    forall a b,
      a + b > 0 ->
      a > 0 \/ b > 0.
  Proof.
    intros.
    destruct (eq_nat_dec a 0); intuition.
  Qed.

  Lemma pigeon :
    forall A (A_eq_dec : forall a a': A, {a = a'} + {a <> a'}) (l : list A) sub1 sub2,
      (forall a, In a sub1 -> In a l) ->
      (forall a, In a sub2 -> In a l) ->
      NoDup l ->
      NoDup sub1 ->
      NoDup sub2 ->
      length sub1 + length sub2 > length l ->
      exists a, In a sub1 /\ In a sub2.
  Proof.
    induction l.
    intros.
    + simpl in *. find_apply_lem_hyp plus_gt_0. intuition.
      * destruct sub1; simpl in *; [omega|].
        specialize (H a). intuition.
      * destruct sub2; simpl in *; [omega|].
        specialize (H0 a). intuition.
    + intros. simpl in *.
      destruct (in_dec A_eq_dec a sub1);
        destruct (in_dec A_eq_dec a sub2); eauto;
            specialize (IHl (remove A_eq_dec a sub1) (remove A_eq_dec a sub2));
            cut (exists a0, In a0 (remove A_eq_dec a sub1) /\ In a0 (remove A_eq_dec a sub2));
            try solve [intros; break_exists;
                       intuition eauto using in_remove];
            apply IHl; try solve [
                             intros; find_copy_apply_lem_hyp in_remove;
                             find_apply_hyp_hyp; intuition; subst; exfalso; eapply remove_In; eauto];
            eauto using remove_NoDup; try solve_by_inversion;
            repeat match goal with
                     | H : ~ In a ?sub |- _ =>
                       assert (length (remove A_eq_dec a sub) = length sub)
                         by eauto using remove_length_not_in; clear H
                     | H : In a ?sub |- _ =>
                       assert (length (remove A_eq_dec a sub) >= length sub - 1)
                         by eauto using remove_length_ge; clear H
                   end; omega.
  Qed.

  Functional Scheme div2_ind := Induction for div2 Sort Prop.

  Theorem div2_correct' :
    forall n,
      n <= div2 n + S (div2 n).
  Proof.
    intro n. functional induction (div2 n); omega.
  Qed.

  Theorem div2_correct :
    forall c a b,
      a > div2 c ->
      b > div2 c ->
      a + b > c.
  Proof.
    intros n. functional induction (div2 n); intros; try omega.
    specialize (IHn0 (pred a) (pred b)). omega.
  Qed.

  Lemma wonElection_one_in_common :
    forall l l',
      wonElection (dedup name_eq_dec l) = true ->
      wonElection (dedup name_eq_dec l') = true ->
      exists h, In h l /\ In h l'.
  Proof.
    intros. unfold wonElection in *. do_bool.
    cut (exists h, In h (dedup name_eq_dec l) /\ In h (dedup name_eq_dec l'));
      [intros; break_exists; exists x; intuition eauto using in_dedup_was_in|].
    eapply pigeon with (l := nodes); eauto using all_fin_all, all_fin_NoDup, NoDup_dedup, name_eq_dec, div2_correct.
  Qed.

  Ltac copy_eapply_prop_hyp P H :=
    match goal with
      | H' : P _ |- _ =>
        let x := fresh in
        pose proof H as x;
          apply H' in x
    end.

  Require Import RaftRefinement.
  Require Import CroniesCorrect.
  Require Import VotesCorrect.

  Lemma one_leader_per_term_invariant' :
    forall net,
      votes_correct net ->
      cronies_correct net ->
      one_leader_per_term (deghost net).
  Proof.
    unfold votes_correct, cronies_correct, one_leader_per_term in *.
    intuition.
    repeat match goal with
             | H : context [ nwState (deghost _) _ ] |- _ =>
               rewrite deghost_spec in H
           end.
    match goal with
      | h : type _ = _, h' : type _ = _ |- _ =>
        copy_eapply_prop_hyp votes_received_leaders h;
          copy_eapply_prop_hyp votes_received_leaders h'
    end.
    match goal with
      | H : wonElection _ = _ |- _ =>
        find_eapply_lem_hyp wonElection_one_in_common; [|clear H; eauto]
    end.
    break_exists; intuition.
    eapply_prop one_vote_per_term;
      eapply_prop cronies_votes;
      [eapply_prop votes_received_cronies|];
      intuition eauto.
    unfold raft_data in *. unfold raft_refined_base_params, raft_refined_multi_params in *.
    repeat find_rewrite.
    eapply_prop votes_received_cronies; intuition eauto.
  Qed.

  Theorem one_leader_per_term_invariant :
    forall net,
      raft_intermediate_reachable net -> one_leader_per_term net.
  Proof.
    intros.
    apply lower_prop; auto.
    intros.
    apply one_leader_per_term_invariant'.
    - eauto using votes_correct_invariant.
    - eauto using cronies_correct_invariant.
  Qed.
End OneLeaderPerTerm.


(** * Techniques for applying theorems from [Sigma.v] to record types. *)
(** * From the HoTT Library *)

Require Import UnivalentParametricity.theories.Basics.

Set Primitive Projections.
Set Universe Polymorphism.

(** The following tactic proves automatically that a two-component record type is equivalent to a Sigma-type.  Specifically, it proves a goal that looks like
<<
   { x : A & B x } <~> Some_Record
>>
   You have to give it the record constructor and the two record projections as arguments (it has no way to guess what those might be). *)

Definition eta_sigma {A} `{P : A -> Type} (u : sigT P)
	  : (u.1; u.2) = u
	  := match u with (x;y) => eq_refl end.

Ltac issig2 build pr1 pr2 :=
  (** Just in case the user supplied a goal which only *reduces* to one of the desired form. *)
  hnf;
  (** Extract the fibration of which our Sigma-type is the total space, as well as the record type. We pull the terms out of a [match], rather than leaving everything inside the [match] because this gives us better error messages. *)
  let fibration := match goal with |- sigT ?fibration ≃ ?record => constr:(fibration) end in
  let record := match goal with |- sigT ?fibration ≃ ?record => constr:(record) end in
  exact (BuildEquiv (sigT fibration) record
                     (fun u => build u.1 u.2)
                     (isequiv_adjointify
                        (fun u => build u.1 u.2)
                       (fun v => existT fibration (pr1 v) (pr2 v))
                       eta_sigma
                       (fun v => let (v1,v2) as v' return (build (pr1 v') (pr2 v') = v') := v in eq_refl)
                       )).
                       (** Since [sigT] is primitve, we get judgmental η, and so we can just use the identity here *)
                       (* (fun _ => eq_refl))). *)

(** This allows us to use the same notation for the tactics with varying numbers of variables. *)
Tactic Notation "issig" constr(build) constr(pr1) constr(pr2) :=
  issig2 build pr1 pr2.

(** We show how the tactic works in a couple of examples. *)

Record Contr (A : Type) := BuildContr {
  center : A ;
  contr : (forall y : A, center = y)
}.

Definition issig_contr (A : Type)
  : { x : A & forall y:A, x = y } ≃ Contr A.
Proof.
  issig (BuildContr A) (@center A) (@contr A).
Defined.

Definition issig_equiv (A B : Type)
  : { f : A -> B & IsEquiv f } ≃ Equiv A B.
Proof.
  issig (BuildEquiv A B) (@e_fun A B) (@e_isequiv A B).
Defined.

(** Here is a version of the [issig] tactic for three-component records, which proves goals that look like
<<
   { x : A & { y : B x & C x y } } <~> Some_Record.
>>
   It takes the record constructor and its three projections as arguments, as before. *)

Definition eta2_sigma {A B} `{P : forall (a : A) (b : B a), Type}
           (u : sigT (fun a => sigT (P a)))
  : (u.1; (u.2.1; u.2.2)) = u.
Proof.
  destruct u as [a [b c]]. reflexivity.
Defined.

Ltac issig3 build pr1 pr2 pr3 :=
  hnf;
  let A := match goal with |- ?A ≃ ?B => constr:(A) end in
  let B := match goal with |- ?A ≃ ?B => constr:(B) end in
  exact (BuildEquiv A B
                    (fun u => build u.1 u.2.1 u.2.2)
                    (isequiv_adjointify
                       (fun u => build u.1 u.2.1 u.2.2)
                       (fun v => (pr1 v; (pr2 v; pr3 v)))
                       eta2_sigma
                       (fun v => let (v1, v2, v3) as v' return (build (pr1 v') (pr2 v') (pr3 v') = v') := v in eq_refl)
                       )).

Tactic Notation "issig" constr(build) constr(pr1) constr(pr2) constr(pr3) :=
  issig3 build pr1 pr2 pr3.

Definition eta3_sigma {A B C} `{P : forall (a : A) (b : B a) (c : C a b), Type}
           (u : sigT (fun a => sigT (fun b => sigT (P a b))))
  : (u.1; (u.2.1; (u.2.2.1; u.2.2.2))) = u.
Proof.
  destruct u as [a [b [c d]]]. reflexivity.
Defined.

(** And a similar version for four-component records.  It should be clear how to extend the pattern indefinitely. *)
Ltac issig4 build pr1 pr2 pr3 pr4 :=
  hnf;
  let A := match goal with |- ?A ≃ ?B => constr:(A) end in
  let B := match goal with |- ?A ≃ ?B => constr:(B) end in
  exact (BuildEquiv  A B
                       (fun u => build u.1 u.2.1 u.2.2.1 u.2.2.2)
                       (isequiv_adjointify
                          (fun u => build u.1 u.2.1 u.2.2.1 u.2.2.2)
                          (fun v => (pr1 v; (pr2 v; (pr3 v; pr4 v))))
                          eta3_sigma
                          (fun v => let (v1, v2, v3, v4) as v' return (build (pr1 v') (pr2 v') (pr3 v') (pr4 v') = v') := v in eq_refl))).

Tactic Notation "issig" constr(build) constr(pr1) constr(pr2) constr(pr3) constr(pr4) :=
  issig4 build pr1 pr2 pr3 pr4.

Definition eta4_sigma {A B C D} `{P : forall (a : A) (b : B a) (c : C a b) (d : D a b c), Type}
           (u : sigT (fun a => sigT (fun b => sigT (fun c => sigT (P a b c)))))
  : (u.1; (u.2.1; (u.2.2.1; (u.2.2.2.1; u.2.2.2.2)))) = u.
Proof.
  destruct u as [a [b [c [d e]]]]. reflexivity.
Defined.

Ltac issig5 build pr1 pr2 pr3 pr4 pr5 :=
  hnf;
  let A := match goal with |- ?A ≃ ?B => constr:(A) end in
  let B := match goal with |- ?A ≃ ?B => constr:(B) end in
  exact (BuildEquiv  A B
                       (fun u => build u.1 u.2.1 u.2.2.1 u.2.2.2.1 u.2.2.2.2)
                       (isequiv_adjointify
                          (fun u => build u.1 u.2.1 u.2.2.1 u.2.2.2.1 u.2.2.2.2)
                          (fun v => (pr1 v; (pr2 v; (pr3 v; (pr4 v ; pr5 v)))))
                          eta4_sigma
                          (fun v => let (v1, v2, v3, v4, v5) as v' return (build (pr1 v') (pr2 v') (pr3 v') (pr4 v') (pr5 v') = v') := v in eq_refl))).

Tactic Notation "issig" constr(build) constr(pr1) constr(pr2) constr(pr3) constr(pr4) constr(pr5) :=
  issig5 build pr1 pr2 pr3 pr4 pr5.

(* A tactic to show that record type are univalent type constructor *)
Ltac univ_param_record :=
  cbn;   split ; [typeclasses eauto | ]; intros;
  unshelve refine (UR_Type_Equiv_gen _ _ _ _ _ _ _ _);
  typeclasses eauto with typeclass_instances.