From Coq Require Export List.
Import ListNotations.
Local Open Scope list_scope.
Require Import Nat.
Require Import Psatz.
Require Import ZArith.

Require Import Common.

Local Open Scope nat_scope.

Inductive binary : Type :=
  | E1
  | E2.

Definition bilist : Type := list binary.

Fixpoint incr1 (b : bilist) : bilist :=
match b with
  | [] => [E1]
  | E1 :: t => let b' := incr1 t in
               if (length b' =? length t) then E1::b' else E2 :: (tl b')
  | E2 :: t => let b' := incr1 t in
               if (length b' =? length t) then E2::b' else E1::b'
end.

Fixpoint decr1 (b:bilist) :=
  match b with
  | [] => []
  | [E1] => []
  | [E2] => [E1]
  | E1::t => let b' := decr1 t in
            if (length b' =? length t) then E1::b' else E2::b'
  | E2::t => let b' := decr1 t in
            if (length b' =? length t) then E2::b' else E1::E2::b'
  end.

Fixpoint incr2 (b : bilist) : bilist :=
match b with
  | [] => [E2]
  | [E1] => [E1; E1]
  | [E2] => [E1; E2]
  | E1 :: t => let b' := incr2 t in
               if (length b' =? length t) then E1::b' else E2 :: (tl b')
  | E2 :: t => let b' := incr2 t in
               if (length b' =? length t) then E2::b' else E1::b'
end.

Lemma neq_in: forall b : bilist,
  incr1 b <> [].
Proof.
  intros.
  induction b.
  simpl. discriminate.
  simpl.
  destruct a.
  destruct (length (incr1 b) =? length b).
  discriminate. discriminate.
  destruct (length (incr1 b) =? length b).
  discriminate. discriminate.
Qed.

Lemma neq_in_r: forall b : bilist,
  [] <> incr1 b.
Proof.
  intros.
  induction b.
  simpl. discriminate.
  simpl.
  destruct a.
  destruct (length (incr1 b) =? length b).
  discriminate. discriminate.
  destruct (length (incr1 b) =? length b).
  discriminate. discriminate.
Qed.

Lemma neq_zero_length: forall b : bilist,
  0 < length (incr1 b).
Proof.
  induction b.
  auto.
  simpl.
  destruct a.
  destruct (length (incr1 b) =? length b).
  simpl. auto.
  simpl. lia.
  destruct (length (incr1 b) =? length b).
  simpl. auto.
  simpl. lia.
Qed.

Lemma E1_head_incr: forall b: bilist,
  (length (incr1 (E1 :: b)) =? length (E1 :: b)) = true.
Proof.
  induction b.
  auto.
  simpl.
  simpl in IHb.
  destruct a.
  remember (length (incr1 b) =? length b) as q.
  destruct q.
  simpl. rewrite <- Heqq.
  simpl. symmetry; auto.
  rewrite IHb.
  auto.
  remember (length (incr1 b) =? length b) as q.
  destruct q.
  simpl. rewrite <- Heqq.
  simpl. symmetry; auto.
  simpl. simpl in IHb.
  rewrite <- Heqq.
  simpl.
  apply PeanoNat.Nat.eqb_eq.
  apply PeanoNat.Nat.eqb_eq in IHb.
  rewrite <- IHb.
  apply length_ge_zero.
  apply neq_zero_length.
Qed.

Lemma E1_head_eq: forall b,
length (incr1 (E1 :: b))  = length (E1 :: b).
Proof.
    intros.
    rewrite <- PeanoNat.Nat.eqb_eq.

    apply E1_head_incr.
Qed.

Lemma length_neq_incr: forall b : bilist,
  (length (incr1 b) =? length b) = false <-> length b < length (incr1 b).
Proof.
    split.
    intros.
    induction b.
    simpl. auto.
    simpl.
    destruct a.
    rewrite E1_head_incr in H.
    inversion H.
    remember (length (incr1 b) =? length b) as q.
    destruct q.
    simpl.
    rewrite <-PeanoNat.Nat.succ_lt_mono.
    apply IHb.
    simpl in H.
    rewrite <- Heqq in H.
    simpl in H.
    rewrite <- Heqq in H.
    inversion H.
    simpl.
    rewrite <-PeanoNat.Nat.succ_lt_mono.
    apply IHb.
    auto.
    (***********)
    induction b.
    simpl.
    auto.
    intros.
    simpl.
    destruct a.
    rewrite E1_head_eq in H.
    apply PeanoNat.Nat.lt_irrefl in H.
    inversion H.
    remember (length (incr1 b) =? length b) as q.
    destruct q.
    simpl.
    simpl in H.
    rewrite <- Heqq in H.
    simpl in H.
    rewrite <-PeanoNat.Nat.succ_lt_mono in H.
    apply IHb in H.
    discriminate.
    simpl.
    simpl in H.
    rewrite <- Heqq in H.
    simpl in H.
    rewrite <-PeanoNat.Nat.succ_lt_mono in H.
    apply PeanoNat.Nat.lt_neq in H.
    apply PeanoNat.Nat.eqb_neq. auto.
Qed.

Lemma length_tl_incr_true: forall b,
  (length (incr1 b) =? length b) = true -> (length (tl (incr1 b)) =? length b) = false.
Proof.
  induction b using list_ind_length.
  simpl.
  auto.
  intros.
  apply EqNat.beq_nat_true in H0.
  rewrite <- H0.
  apply tl_greater.
  apply neq_zero_length.
Qed.

Lemma tl_greater_eq: forall b : bilist,
  0 < length b -> S (length (tl b)) = (length b) .
Proof.
  intros.
  induction b.
  inversion H.
  simpl. auto.
Qed.

Lemma length_le_S: forall b,
  length b < length (incr1 b) -> S (length b) = length (incr1 b).
Proof.
  induction b.
  auto.
  intros.
  simpl.
  destruct a.
  remember (length (incr1 b) =? length b).
  destruct b0.
  simpl.
  apply eq_S.
  apply IHb.
  simpl in H.
  rewrite <- Heqb0 in H.
  simpl in H.
  apply Lt.lt_S_n in H.
  auto.
  simpl.
  simpl in H.
  rewrite <- Heqb0 in H.
  simpl in H.
  apply eq_S.
  apply Lt.lt_S_n in H.
  symmetry in Heqb0.
  apply length_neq_incr in Heqb0.
  apply IHb in Heqb0.
  apply Lt.lt_n_S in H.
  rewrite Heqb0 in H.
  rewrite <- tl_greater_eq in H.
  lia.
  apply neq_zero_length.
  remember (length (incr1 b) =? length b).
  destruct b0.
  simpl.
  apply eq_S.
  apply IHb.
  simpl in H.
  rewrite <- Heqb0 in H.
  simpl in H.
  apply Lt.lt_S_n in H.
  auto.
  simpl.
  simpl in H.
  rewrite <- Heqb0 in H.
  simpl in H.
  apply eq_S.
  apply Lt.lt_S_n in H.
  symmetry in Heqb0.
  apply length_neq_incr in Heqb0.
  apply IHb in Heqb0.
  auto.
Qed.

Lemma tl_S: forall b,
  S (length (tl (incr1 b))) = length (incr1 b).
Proof.
  induction b.
  auto.
  destruct a.
  simpl.
  remember (length (incr1 b) =? length b).
  destruct b0.
  simpl.
  auto.
  simpl.
  auto.
  simpl.
  remember (length (incr1 b) =? length b).
  destruct b0.
  simpl.
  auto.
  simpl.
  auto.
Qed.

Lemma length_eq_incr_S: forall b,
  (length (incr1 b) =? length b) = false -> length (incr1 b) = S (length b).
Proof.
  induction b using list_ind_length.
  auto.
  intros.
  destruct b.
  auto.
  destruct b.
  simpl.
  rewrite E1_head_incr in H0.
  inversion H0.
  simpl.
  remember (length (incr1 b0) =? length b0).
  destruct b.
  simpl.
  rewrite PeanoNat.Nat.succ_inj_wd.
  apply H.
  auto.
  simpl in H0.
  rewrite <- Heqb in H0.
  simpl in H0.
  auto.
  simpl.
  rewrite PeanoNat.Nat.succ_inj_wd.
  simpl in H0.
  remember (length (incr1 b0) =? length b0).
  destruct b.
  inversion Heqb.
  apply H.
  auto. auto.
Qed.

Lemma length_incr_tl: forall b,
  length b < length (incr1 b) -> length (tl (incr1 b)) = length b .
Proof.
  induction b.
  auto.
  intros.
  destruct a.
  simpl.
  remember (length (incr1 b) =? length b ).
  destruct b0.
  simpl.
  rewrite E1_head_eq in H.
  lia.
  simpl.
  rewrite E1_head_eq in H.
  lia.
  simpl.
  remember (length (incr1 b) =? length b ).
  destruct b0.
  simpl.
  symmetry in Heqb0.
  rewrite PeanoNat.Nat.eqb_eq in Heqb0.
  apply length_eq_head with (h := E2) in Heqb0.
  simpl in Heqb0.
  apply eq_add_S in Heqb0.
  simpl in H.
  remember (length (incr1 b) =? length b ).
  destruct b0.
  simpl in H.
  rewrite Heqb0 in H.
  lia.
  simpl in H.
  lia.
  simpl.
  apply length_eq_incr_S.
  auto.
Qed.

Lemma incr1_cons2: forall b, length b < length (incr1 b) ->
Forall (eq E2) b .
Proof.
  induction b.
  simpl.
  auto.
  intros.
  apply Forall_cons.
  destruct a.
  simpl in H.
  remember (length (incr1 b) =? length b) as q.
  destruct q.
  simpl in H.
  rewrite <- PeanoNat.Nat.succ_lt_mono in H.
  rewrite <- length_neq_incr in H.
  rewrite <- Heqq in H.
  inversion H.
  simpl in H.
  rewrite <- PeanoNat.Nat.succ_lt_mono in H.
  symmetry in Heqq.
  apply length_neq_incr in Heqq.
  apply length_incr_tl in Heqq.
  lia.
  auto.
  apply IHb.
  rewrite <- length_neq_incr in H.
  rewrite <- length_neq_incr.
  simpl.
  destruct a.
  simpl in H.
  remember (length (incr1 b) =? length b ).
  destruct b0.
  simpl in H.
  rewrite H in Heqb0.
  auto.
  simpl in H. auto.
  simpl in H.
  remember (length (incr1 b) =? length b ).
  destruct b0.
  simpl in H.
  rewrite H in Heqb0.
  auto.
  auto.
Qed.

Lemma incr1_cons1: forall b,
  length b  < length (incr1 b) -> Forall (eq E1) (incr1 b).
Proof.
  induction b using list_ind_length.
  simpl. auto.
  intros.
  simpl.
  destruct b.
  simpl. auto.
  destruct b.
  simpl.
  remember (length (incr1 b0) =? length b0).
  destruct b.
  apply Forall_cons. auto.
  apply H.
  auto.
  simpl in H0.
  rewrite <- Heqb in H0.
  simpl in H0.
  apply Lt.lt_S_n in H0.
  apply length_le_S in H0.
  rewrite <- H0 in Heqb.
  lia.
  simpl in H0.
  rewrite <- Heqb in H0.
  simpl in H0.
  apply Lt.lt_S_n in H0.
  symmetry in Heqb.
  apply length_neq_incr in Heqb.
  apply length_incr_tl in Heqb.
  lia.
  simpl in H0.
  simpl.
  remember (length (incr1 b0) =? length b0).
  destruct b.
  simpl in H0.
  symmetry in Heqb.
  apply Lt.lt_S_n in H0.
  apply PeanoNat.Nat.eqb_eq in Heqb.
  lia.
  apply Forall_cons.
  auto.
  apply H.
  auto.
  symmetry in Heqb.
  apply length_neq_incr in Heqb.
  auto.
Qed.

Lemma incr1_tl_comm_E1: forall b, 1 < (length b) -> Forall (eq E1) b ->
  incr1 (tl b) = tl (incr1 b).
Proof.
  induction b using list_ind_length.
  simpl. intros. inversion H.
  intros.
  destruct b.
  simpl in H0. inversion H0.
  destruct b.
  simpl in *.
  remember (length (incr1 b0) =? length b0).
  destruct b.
  simpl.
  auto.
  simpl.
  symmetry in Heqb.
  apply length_neq_incr in Heqb.
  apply incr1_cons2 in Heqb.
  inversion_clear H1.
  destruct b0.
  simpl in H0. lia.
  inversion_clear Heqb.
  inversion_clear H3.
  rewrite <- H1 in H5.
  inversion H5.
  inversion_clear H1.
  inversion H2.
Qed.

Lemma incr1_tl_comm_E2: forall b, 0 < (length b) -> Forall (eq E2) b ->
  incr1 (tl b) = tl (incr1 b).
Proof.
  induction b using list_ind_length.
  simpl. lia.
  intros.
  destruct b.
  auto.
  simpl.
  destruct b.
  inversion_clear H1.
  inversion H2.
  inversion_clear H1.
  remember (length (incr1 b0) =? length b0).
  destruct b.
  simpl.
  auto.
  simpl.
  auto.
Qed.

Lemma incr1_length: forall b, length b <= length (incr1 b).
Proof.
  induction b using list_ind_length.
  simpl. lia.
  destruct b. simpl. auto.
  simpl.
  destruct b.
  -
  remember (length (incr1 b0) =? length b0).
  destruct b.
  + enough (length b0 <= length (incr1 b0)).
  simpl. lia. apply H. simpl. auto.
  + symmetry in Heqb.
  apply PeanoNat.Nat.eqb_neq in Heqb.
  simpl.
  enough (length b0 < length (incr1 b0) ).
  destruct (incr1 b0); simpl.
  destruct b0; simpl in H0; lia.
  simpl in H0. lia.
  enough (length b0 <= length (incr1 b0)).
  lia. apply H. simpl. lia.
  - remember (length (incr1 b0) =? length b0).
  destruct b.
  + enough (length b0 <= length (incr1 b0)).
  simpl. lia. apply H. simpl. auto.
  + symmetry in Heqb.
  apply PeanoNat.Nat.eqb_neq in Heqb.
  simpl.
  enough (length b0 < length (incr1 b0) ).
  destruct (incr1 b0); simpl.
  destruct b0; simpl in H0; lia.
  simpl in H0. lia.
  enough (length b0 <= length (incr1 b0)).
  lia. apply H. simpl. lia.
Qed.

Lemma incr1_cons2_inv: forall b, Forall (eq E2) b -> length b < length (incr1 b).
Proof.
  intros.
  induction b using list_ind_length.
  simpl. lia.
  destruct b.
  simpl. lia.
  inversion_clear H.
  simpl.
  remember (length (incr1 b0) =? length b0).
  rewrite <- H1.
  enough (b1 = false).
  rewrite H.
  simpl.
  enough ((length b0) < (length (incr1 b0))).
  lia.
  apply H0. simpl. auto. auto.
  rewrite Heqb1.
  apply PeanoNat.Nat.eqb_neq.
  enough (length b0 < length (incr1 b0)).
  lia. apply H0. simpl. auto.
  auto.
Qed.

Lemma incr1_cons_over: forall b b0, length (incr1 (b :: b0)) <> length (b :: b0) ->
        length (incr1 b0) <> length b0.
Proof.
  intros.
  generalize dependent b.
  induction b0 using list_ind_length; intros.
  simpl. lia.
  enough (length (b :: b0) < length (incr1 (b :: b0)) ).
  apply incr1_cons2 in H1.
  inversion_clear H1.
  remember (incr1_cons2_inv b0).
  apply l in H3. lia.
  enough (length (b :: b0) <= length (incr1 (b :: b0))).
  lia.
  apply incr1_length.
Qed.

Lemma decr1_incr1: forall b, decr1 (incr1 b) = b.
Proof.
  intros.
  induction b using list_ind_length.
  simpl. auto.

  destruct b. simpl. auto.
  simpl.
  remember (length (incr1 b0) =? length b0).
  destruct b; destruct b1.
  all: simpl.
  all: try rewrite H.
  all: auto.
  -
  remember (incr1 b0).
  destruct b.
  destruct b0. simpl in Heqb. discriminate.
  simpl in Heqb.
  destruct b; destruct (length (incr1 b0) =? length b0); discriminate.
  replace (length b0 =? length (b :: b1)) with true. auto.
  rewrite Heqb1. apply PeanoNat.Nat.eqb_sym.
  - destruct b0. simpl. auto.
  rewrite <- incr1_tl_comm_E2.
  simpl tl.
  remember (incr1 b0).
  destruct b1.
  destruct b0. simpl in Heqb0. discriminate.
  simpl in Heqb0.
  destruct b0; destruct (length (incr1 b1) =? length b1); discriminate.
  rewrite Heqb0.
  rewrite H.
  replace (length b0 =? length (incr1 b0)) with false.
  replace b with E2. auto.
  enough (Forall (eq E2) (b::b0)).
  inversion H0. auto.
  apply incr1_cons2.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_neq in Heqb1.
  enough (length (b :: b0) <= length (incr1 (b :: b0))).
  lia. apply incr1_length.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_neq in Heqb1.
  apply incr1_cons_over in Heqb1.
  symmetry.
  apply PeanoNat.Nat.eqb_neq. lia.
  simpl. auto.
  simpl. lia.
  apply incr1_cons2.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_neq in Heqb1.
  enough (length (b :: b0) <= length (incr1 (b :: b0))).
  lia. apply incr1_length.
  - remember (incr1 b0).
  destruct b.
  destruct b0. simpl in Heqb. discriminate.
  simpl in Heqb.
  destruct b; destruct (length (incr1 b0) =? length b0); discriminate.
  replace (length b0 =? length (b :: b1)) with true.
  auto.
  rewrite Heqb1.
  apply PeanoNat.Nat.eqb_sym.
  - destruct b0. simpl. auto.
  remember (incr1 (b::b0)).
  destruct b1.
  simpl in Heqb0.
  destruct b; destruct (length (incr1 b0) =? length b0); discriminate.
  rewrite Heqb0. rewrite Heqb0 in Heqb1.
  replace (length (b :: b0) =? length (incr1 (b :: b0))) with false.
  auto. rewrite Heqb1.
  apply PeanoNat.Nat.eqb_sym.
Qed.

Lemma incr1_decr1: forall b,
  0 < length b -> incr1 (decr1 b) = b.
Proof.
  intros.
  induction b using list_ind_length.
  simpl in H. lia.

  destruct b. simpl in H. lia.
  simpl.
  destruct b0.
  destruct b. auto. auto.
  remember (length (decr1 (b0 :: b1)) =? length (b0 :: b1)).
  remember ((b0 :: b1)).
  destruct b; destruct b2.
  -
  simpl. rewrite H0.
  replace (length l =? length (decr1 l)) with true.
  auto.
  rewrite Heqb2.
  apply PeanoNat.Nat.eqb_sym. auto.
  rewrite Heql. simpl. lia.
  -
  simpl. rewrite H0.
  replace (length l =? length (decr1 l)) with false.
  auto.
  rewrite Heqb2.
  apply PeanoNat.Nat.eqb_sym. auto.
  rewrite Heql. simpl. lia.
  - simpl. rewrite H0.
  replace (length l =? length (decr1 l)) with true.
  auto.
  rewrite Heqb2.
  apply PeanoNat.Nat.eqb_sym. auto.
  rewrite Heql. simpl. lia.
  - simpl. rewrite H0.
  replace (length l =? length (decr1 l)) with false.
  simpl.
  replace (length l =? length (decr1 l)) with false.
  auto.
  rewrite Heqb2.
  apply PeanoNat.Nat.eqb_sym.
  rewrite Heqb2.
  apply PeanoNat.Nat.eqb_sym.
  auto.
  rewrite Heql. simpl. lia.
Qed.

Lemma incr1_length_plus: forall b, length b < length (incr1 b) ->
                                    S (length b) =  length (incr1 b).
Proof.
  intros.
  induction b using list_ind_length. auto.
  destruct b. auto.
  simpl. simpl in H.
  remember (length (incr1 b0) =? length b0) as q.
  destruct b; destruct q.
  all: symmetry in Heqq.
  all: first [ apply PeanoNat.Nat.eqb_eq in Heqq | apply PeanoNat.Nat.eqb_neq in Heqq ].
  all: simpl.
  all: simpl in H.
  - exfalso. lia.
  -
  exfalso.
  remember (length b0 =? length (incr1 b0)).
  destruct b.
  symmetry in Heqb. apply PeanoNat.Nat.eqb_eq in Heqb.
  congruence.
  symmetry in Heqb. apply PeanoNat.Nat.eqb_neq in Heqb.
  enough (length b0 < length (incr1 b0)).
  apply H0 in H1; auto.
  rewrite H1 in H.
  destruct b0. simpl in H. lia.
  remember (incr1 (b :: b0)).
  destruct b1.
  simpl in Heqb1.
  destruct b; destruct (length (incr1 b0) =? length b0); discriminate.
  simpl in H. lia.
  enough (length b0 <= length (incr1 b0)).
  lia. apply incr1_length.
  - enough (length b0 < length (incr1 b0)).
  apply H0 in H1; auto.
  lia.
  - enough (length b0 < length (incr1 b0)).
  apply H0 in H1; auto.
  lia.
Qed.

Lemma incr2_length: forall b, length b <= length (incr2 b).
Proof.
  induction b using list_ind_length.
  simpl. lia.
  destruct b. simpl. auto.
  simpl.
  destruct b.
  -
  remember (length (incr2 b0) =? length b0).
  destruct b.
  +
  destruct b0. simpl. auto.
  remember (b :: b0) as b1.
  enough (length b1 <= length (incr2 b1)).
  simpl. lia. apply H. simpl. auto.
  + destruct b0. simpl. auto.
  remember (b :: b0) as b1.
  symmetry in Heqb.
  apply PeanoNat.Nat.eqb_neq in Heqb.
  simpl.
  enough (length b1 < length (incr2 b1) ).
  destruct (incr2 b1); simpl.
  destruct b1; simpl in H0; lia.
  simpl in H0. lia.
  enough (length b1 <= length (incr2 b1)).
  lia. apply H. simpl. lia.
  - destruct b0. simpl. auto.
  remember (b :: b0) as b1.
  remember (length (incr2 b1) =? length b1).
  destruct b2.
  + enough (length b1 <= length (incr2 b1)).
  simpl. lia. apply H. simpl. auto.
  + symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_neq in Heqb2.
  simpl.
  enough (length b1 < length (incr2 b1)).
  destruct (incr2 b1); simpl.
  destruct b1; simpl in H0; lia.
  simpl in H0. lia.
  enough (length b1 <= length (incr2 b1)).
  lia. apply H. simpl. lia.
Qed.

Lemma incr2_length_plus: forall b, length b < length (incr2 b) ->
                                    S (length b) =  length (incr2 b).
Proof.
  intros.
  induction b using list_ind_length. auto.
  destruct b. auto.
  simpl. simpl in H.
  remember (length (incr2 b0) =? length b0) as q.
  destruct b; destruct q.
  all: symmetry in Heqq.
  all: first [ apply PeanoNat.Nat.eqb_eq in Heqq | apply PeanoNat.Nat.eqb_neq in Heqq ].
  all: simpl.
  all: simpl in H.
  - exfalso. destruct b0. simpl in Heqq. lia.
  remember (b :: b0) as b1. simpl in H. lia.
  -
  destruct b0. simpl. auto.
  exfalso.
  remember (b :: b0) as b1. simpl in H.
  remember (length b1 =? length (incr2 b1)).
  destruct b2.
  symmetry in Heqb2. apply PeanoNat.Nat.eqb_eq in Heqb2.
  congruence.
  symmetry in Heqb2. apply PeanoNat.Nat.eqb_neq in Heqb2.
  enough (length b1 < length (incr2 b1)).
  apply H0 in H1; auto.
  rewrite H1 in H.
  remember (incr2 b1).
  destruct b2.
  simpl in Heqb2.
  destruct b1; simpl in H1; discriminate.
  simpl in H. lia.
  enough (length b1 <= length (incr2 b1)).
  lia. apply incr2_length.
  -
  destruct b0. simpl. auto.
  remember (b :: b0) as b1.
  enough (length b1 < length (incr2 b1)).
  apply H0 in H1; auto. simpl. congruence.
  simpl in H. lia.
  -
  destruct b0. simpl. auto.
  remember (b :: b0) as b1.
  enough (length b1 < length (incr2 b1)).
  apply H0 in H1; simpl; auto.
  simpl in H. lia.
Qed.

Lemma incr2_incr1_length: forall b, length (incr1 b) <= length (incr2 b).
Proof.
  induction b using list_ind_length.
  simpl. lia.
  destruct b. simpl. auto.
  simpl.
  destruct b.
  all: destruct b0; auto.
  simpl. lia.
  all: remember b0 as b2.
  all: clear Heqb2.
  all: clear b0.
  all: remember (b :: b2) as b0.
  -
  remember (length (incr1 b0) =? length b0) as p.
  remember (length (incr2 b0) =? length b0) as q.
  destruct p; destruct q.
  + enough (length (incr1 b0) <= length (incr2 b0)).
  simpl. lia. apply H. simpl. auto.
  + symmetry in Heqp. symmetry in Heqq.
  apply PeanoNat.Nat.eqb_eq in Heqp.
  apply PeanoNat.Nat.eqb_neq in Heqq.
  simpl.
  enough (length (incr1 b0) < length (incr2 b0) ).
  destruct (incr2 b0); simpl.
  destruct b0; simpl in H0; lia.
  simpl in H0. lia.
  enough (length b0 <= length (incr2 b0)).
  enough (length b0 <= length (incr1 b0)).
  lia. apply incr1_length. apply incr2_length.
  + symmetry in Heqp. symmetry in Heqq.
  apply PeanoNat.Nat.eqb_neq in Heqp.
  apply PeanoNat.Nat.eqb_eq in Heqq.
  exfalso.
  enough (length b0 <= length (incr2 b0)).
  enough (length b0 <= length (incr1 b0)).
  enough (length (incr1 b0) <= length (incr2 b0)).
  lia. apply H. auto. apply incr1_length. apply incr2_length.
  +  symmetry in Heqp. symmetry in Heqq.
  apply PeanoNat.Nat.eqb_neq in Heqp.
  apply PeanoNat.Nat.eqb_neq in Heqq.
  simpl.
  enough (length (incr1 b0) <= length (incr2 b0)).
  destruct (incr1 b0) ; destruct (incr2 b0); try lia; auto.
  simpl. destruct b1; simpl; lia.
  apply H; auto.
  - remember (length (incr1 b0) =? length b0) as p.
  remember (length (incr2 b0) =? length b0) as q.
  destruct p; destruct q.
  + enough (length (incr1 b0) <= length (incr2 b0)).
  simpl. lia. apply H. simpl. auto.
  + symmetry in Heqp. symmetry in Heqq.
  apply PeanoNat.Nat.eqb_eq in Heqp.
  apply PeanoNat.Nat.eqb_neq in Heqq.
  simpl.
  enough (length (incr1 b0) < length (incr2 b0) ).
  destruct (incr2 b0); simpl.
  destruct b0; simpl in H0; lia.
  simpl in H0. lia.
  enough (length b0 <= length (incr2 b0)).
  enough (length b0 <= length (incr1 b0)).
  lia. apply incr1_length. apply incr2_length.
  + symmetry in Heqp. symmetry in Heqq.
  apply PeanoNat.Nat.eqb_neq in Heqp.
  apply PeanoNat.Nat.eqb_eq in Heqq.
  exfalso.
  enough (length b0 <= length (incr2 b0)).
  enough (length b0 <= length (incr1 b0)).
  enough (length (incr1 b0) <= length (incr2 b0)).
  lia. apply H. auto. apply incr1_length. apply incr2_length.
  +  symmetry in Heqp. symmetry in Heqq.
  apply PeanoNat.Nat.eqb_neq in Heqp.
  apply PeanoNat.Nat.eqb_neq in Heqq.
  simpl.
  enough (length (incr1 b0) <= length (incr2 b0)).
  destruct (incr1 b0) ; destruct (incr2 b0); try lia; auto.
  apply H; auto.
Qed.

Lemma incr1_E1: forall b, 0 < length b -> Forall (eq E1) b ->
    length b = length (incr1 b).
Proof.
    induction b using list_ind_length; intros.
    simpl in H. lia.
    destruct b. simpl. simpl in H0. lia.
    inversion_clear H1.
    simpl.
    remember (length (incr1 b0) =? length b0) as q.
  destruct b; destruct q.
  all: symmetry in Heqq.
  all: first [ apply PeanoNat.Nat.eqb_eq in Heqq | apply PeanoNat.Nat.eqb_neq in Heqq ].
  all: simpl.
  all: simpl in H0.
  - lia.
  - enough (length b0 < length (incr1 b0)).
  apply incr1_length_plus in H1.
  rewrite H1.
  destruct (incr1 b0). simpl in H1.
  lia. simpl. auto.
  enough (length b0 <= length (incr1 b0)).
  lia.
  apply incr1_length.
  - congruence.
  - discriminate.
Qed.

Lemma incr2_incr1: forall b, incr1 (incr1 b) = incr2 b.
Proof.
  induction b using list_ind_length.
  auto.
  destruct b. simpl. auto. simpl.

  destruct b0. simpl.
  destruct b; auto.

  all: remember b0 as b2.
  all: clear Heqb2.
  all: clear b0.
  all: remember (b2 :: b1) as b0.

  remember (length (incr1 b0) =? length b0) as q1.
  remember (length (incr2 b0) =? length b0) as q2.

  destruct b; destruct q1; destruct q2; simpl.
  all: try rewrite H; auto.

  all: symmetry in Heqq1.
  all: symmetry in Heqq2.
  all: first [ apply PeanoNat.Nat.eqb_eq in Heqq1 | apply PeanoNat.Nat.eqb_neq in Heqq1 ].
  all: first [ apply PeanoNat.Nat.eqb_eq in Heqq2 | apply PeanoNat.Nat.eqb_neq in Heqq2 ].

  -
  replace (length (incr2 b0) =? length (incr1 b0)) with true. auto.
  symmetry. apply PeanoNat.Nat.eqb_eq. congruence.

  -
  replace (length (incr2 b0) =? length (incr1 b0)) with false. auto.
  symmetry. apply PeanoNat.Nat.eqb_neq. congruence.

  - exfalso.
  enough (length b0 <= length (incr1 b0)).
  enough (length b0 <= length (incr2 b0)).
  enough (length (incr1 b0) <= length (incr2 b0)).
  lia.
  apply incr2_incr1_length.
  apply incr2_length.
  apply incr1_length.

  - replace (length (incr1 (tl (incr1 b0))) =? length (tl (incr1 b0))) with true.
  destruct b0. simpl. discriminate.
  destruct b0. simpl. destruct b; auto.
  rewrite <- H.
  rewrite incr1_tl_comm_E1; auto.
  enough (length (b :: b0 :: b3) <= length (incr1 (b :: b0 :: b3))).
  simpl in H0. simpl. lia.
  apply incr1_length.
  apply incr1_cons1.
  enough (length (b :: b0 :: b3) <= length (incr1 (b :: b0 :: b3))).
  lia.  apply incr1_length.
  simpl. lia.
  symmetry.
  apply PeanoNat.Nat.eqb_eq .
  rewrite <- incr1_E1. auto.
  rewrite Heqb0.
  simpl.
  destruct b2; destruct (length (incr1 b1) =? length b1); simpl; auto.
  + destruct b1. simpl. auto.
    simpl. destruct (length (incr1 b1) =? length b1); destruct b; simpl; try lia.
  + rewrite Heqb0 in Heqq1.
  enough (length (E1 :: b1) < length (incr1 (E1 :: b1)))  .
  apply incr1_cons2 in H0.
  inversion H0. discriminate.
  enough (length (E1 :: b1) <= length (incr1 (E1 :: b1))).
  lia.
  apply incr1_length.
  + destruct b1. auto.
  simpl. destruct b; destruct (length (incr1 b1) =? length b1); simpl; lia.
  + destruct b1. auto.
  simpl. destruct b; destruct (length (incr1 b1) =? length b1); simpl; lia.
  +
  enough (length b0 < length (incr1 b0)).
  apply incr1_cons1 in H0.
  destruct (incr1 b0).
  auto.
  inversion H0. simpl. auto.
  enough (length b0 <= length (incr1 b0)).
  lia.
  apply incr1_length.
  - replace (length (incr2 b0) =? length (incr1 b0)) with true.
  auto.
  symmetry. apply PeanoNat.Nat.eqb_eq. congruence.
  - replace (length (incr2 b0) =? length (incr1 b0)) with false.
  auto.
  symmetry. apply PeanoNat.Nat.eqb_neq. congruence.
  - exfalso.
  enough (length b0 < length (incr1 b0)).
  enough (length (incr1 b0) <= length (incr2 b0)).
  lia.
  apply incr2_incr1_length.
  enough (length b0 <= length (incr1 b0)).
  lia.
  apply incr1_length.
  - replace (length (incr2 b0) =? length (incr1 b0)) with true.
  auto.
  symmetry. apply PeanoNat.Nat.eqb_eq.
  rewrite <- incr1_length_plus.
  rewrite <- incr2_length_plus.
  auto.
  enough (length b0 <= length (incr2 b0)).
  lia.
  apply incr2_length.
  enough (length b0 <= length (incr1 b0)).
  lia.
  apply incr1_length.
Qed.

Lemma iter_decr1_nil: forall n, iter n decr1 [] = [].
Proof.
  intros.
  induction n; intros.
  simpl. auto.
  simpl. auto.
Qed.

Lemma decr1_length: forall a, length (decr1 a) <= length a.
Proof.
  intros.
  destruct a.
  simpl. lia.
  remember (b::a) as a'.
  rewrite <- incr1_decr1 with (b:=a') at 2.
  apply incr1_length.
  rewrite Heqa'.
  simpl. lia.
Qed.

Lemma incr2_in_next: forall y b, length (incr1 y) = length y ->
length (incr2 (y++[b])) = length (y ++[b]).
Proof.
  intros.
  generalize dependent b.
  induction y using list_ind_length; intros.
  simpl in H.
  lia.
  destruct y.
  simpl in H. lia.
  simpl.
  simpl in H.
  remember (length (incr1 y) =? length y).
  remember (length (incr2 (y ++ [b])) =? length (y ++ [b])).
  remember (y++[b]).
  destruct l.
  destruct y; simpl in Heql; discriminate.
  rewrite Heql.
  rewrite Heql in Heqb2.
  destruct b0; destruct b1; destruct b2.
  - (*8*)
  simpl in H.
  simpl.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_eq in Heqb2.
  lia.
  - (*7*)
  simpl in H.
  simpl.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_neq in Heqb2.
  inversion H.
  apply H0  with (b:=b) in H2.
  contradiction.
  simpl. lia.
  - (*6*)
  simpl in H.
  simpl.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_eq in Heqb2.
  lia.
  - (*5*)
  simpl in H.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_neq in Heqb2.
  simpl.
  enough (length (incr2 (y ++ [b])) = S (length (y ++ [b]))).
  destruct (incr2 (y ++ [b])).
  simpl in H1.
  lia.
  simpl in H1. simpl.
  lia.
  rewrite incr2_length_plus.
  auto.
  enough (length (y ++ [b]) <= length (incr2 (y ++ [b]))).
  lia.
  apply incr2_length.
  - (*4*)
  simpl in H.
  simpl.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_eq in Heqb2.
  lia.
  - (*3*)
  simpl in H.
  inversion H.
  apply H0 with (b:=b) in H2 .
  simpl. lia.
  simpl. lia.
  - (*2*)
  simpl in H. simpl.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_eq in Heqb2.
  lia.
  - (*1*)
  simpl in H. simpl.
  symmetry in Heqb2.
  apply PeanoNat.Nat.eqb_neq in Heqb2.
  inversion H.
  apply H0  with (b:=b) in H2.
  contradiction.
  simpl. lia.
Qed.

Lemma incr2_in_next_inv: forall y b,
length (incr2 (y++[b])) = length (y ++[b]) ->
length (incr1 y) = length y.
Proof.
  intros.
  generalize dependent b.
  induction y using list_ind_length; intros.
  simpl. simpl in H.
  destruct b.
  simpl in H. lia.
  simpl in H. lia.
  destruct y.
  simpl in H0.
  destruct b; simpl in H0; lia.
  simpl.
  simpl in H0.
  remember (length (incr1 y) =? length y).
  remember (length (incr2 (y ++ [b])) =? length (y ++ [b])).
  remember (y++[b]).
  destruct l.
  destruct y; simpl in Heql; discriminate.
  rewrite Heql in H0.
  rewrite Heql in Heqb2.
  destruct b0; destruct b2; destruct b1.
  - (*8*)
  simpl in H0.
  simpl.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_eq in Heqb1.
  lia.
  - (*7*)
  simpl in H0.
  simpl.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_neq in Heqb1.
  inversion H0.
  apply H with (b:=b) in H2.
  contradiction.
  simpl. lia.
  - (*6*)
  simpl in H0.
  simpl.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_eq in Heqb1.
  lia.
  - (*5*)
  simpl in H0.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_neq in Heqb1.
  simpl.
  enough (length (incr1 y) = S (length y)).
  destruct (incr1 y).
  simpl in H1.
  lia.
  simpl in H1. simpl.
  lia.
  rewrite incr1_length_plus.
  auto.
  enough (length y <= length (incr1 y)).
  lia.
  apply incr1_length.
  - (*4*)
  simpl in H0.
  simpl.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_eq in Heqb1.
  lia.
  - (*3*)
  simpl in H0.
  inversion H0.
  apply H with (b:=b) in H2 .
  simpl. lia.
  simpl. lia.
  - (*2*)
  simpl in H0. simpl.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_eq in Heqb1.
  lia.
  - (*1*)
  simpl in H0. simpl.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_neq in Heqb1.
  inversion H0.
  apply H with (b:=b) in H2.
  contradiction.
  simpl. lia.
Qed.

Lemma iter_incr1_tail_helper1: forall b y,
incr2 (y ++ [b]) = incr1 y ++ [b].
Proof.
  intros.
  generalize dependent b.
  induction y using list_ind_length; intros.
  simpl.
  destruct b; auto.
  destruct y.
  destruct b; auto.
  simpl.
  remember (y ++ [b]).
  destruct l.
  destruct y; simpl in Heql; discriminate.
  remember (length (incr2 (b1 :: l)) =? length (b1 :: l)).
  remember (length (incr1 y) =? length y).
  destruct b0; destruct b2; destruct b3.
  - (*8*)
  rewrite Heql.
  rewrite H.
  auto.
  simpl. lia.
  -(*7*)
  rewrite Heql in Heqb2.
  symmetry in Heqb2. symmetry in Heqb3.
  apply PeanoNat.Nat.eqb_eq in Heqb2.
  apply PeanoNat.Nat.eqb_neq in Heqb3.
  apply incr2_in_next_inv in Heqb2.
  contradiction.
  -(*6*)
  rewrite Heql in Heqb2.
  symmetry in Heqb2. symmetry in Heqb3.
  apply PeanoNat.Nat.eqb_eq in Heqb3.
  apply PeanoNat.Nat.eqb_neq in Heqb2.
  apply incr2_in_next with (b:=b) in Heqb3.
  contradiction.
  -(*5*)
  rewrite Heql in Heqb2.
  rewrite Heql.
  rewrite H.
  remember (incr1 y).
  destruct b0.
  simpl.
  exfalso.
  destruct y. simpl in Heqb0. discriminate.
  simpl in Heqb0.
  destruct b0; destruct (length (incr1 y) =? length y); discriminate.
  simpl.
  auto.
  simpl. lia.
  -(*4*)
  rewrite Heql.
  rewrite H.
  auto.
  simpl. lia.
  - (*3*)
  rewrite Heql in Heqb2.
  symmetry in Heqb2. symmetry in Heqb3.
  apply PeanoNat.Nat.eqb_neq in Heqb3.
  apply PeanoNat.Nat.eqb_eq in Heqb2.
  apply incr2_in_next_inv in Heqb2.
  contradiction.
  - (*2*)
  rewrite Heql in Heqb2.
  symmetry in Heqb2. symmetry in Heqb3.
  apply PeanoNat.Nat.eqb_eq in Heqb3.
  apply PeanoNat.Nat.eqb_neq in Heqb2.
  apply incr2_in_next with (b:=b) in Heqb3.
  contradiction.
  -(*1*)
  rewrite Heql in Heqb2.
  rewrite Heql.
  rewrite H.
  remember (incr1 y).
  destruct b0.
  simpl. auto. auto.
  simpl. lia.
Qed.

Lemma iter_incr1_tail_helper2: forall b y n1,
n1 <= length y ->
incr2 (b :: firstn n1 y) ++ skipn n1 y = incr1 (firstn n1 (b :: y)) ++ skipn n1 (b :: y).
Proof.
  intros.
  remember (firstn n1 (b :: y)).
  enough (exists x, b :: firstn n1 y = l ++ [x]).
  destruct H0.
  rewrite H0.
  rewrite iter_incr1_tail_helper1.
  rewrite app_ass.
  enough ([x] ++ skipn n1 y =  skipn n1 (b :: y)).
  rewrite H1. auto.
  subst l.
  generalize dependent y.
  generalize dependent b.
  generalize dependent x.
  induction n1; intros.
  simpl.
  simpl in H0.
  inversion H0. auto.
  destruct y.
  simpl in H. lia.
  simpl in H0.
  enough (b0 :: firstn n1 y = firstn n1 (b0 :: y) ++ [x]).
  apply IHn1 in H1.
  simpl.
  simpl in H1. auto.
  simpl in H. lia.
  inversion H0. auto.
  subst l.
  generalize dependent y.
  generalize dependent b.
  induction n1; intros.
  simpl.
  exists b. auto.
  destruct y.
  simpl in H. lia.
  simpl in H.
  enough (n1 <=length y).
  simpl.
  apply IHn1 with (b:=b0) in H0.
  destruct H0.
  rewrite H0.
  exists x.
  auto.
  lia.
Qed.

Lemma iter_incr1_tail_helper3: forall n1 b y, n1 <= length y ->
exists (h : binary) (t : list binary), skipn n1 (b :: y) = h :: t.
Proof.
  intros.
  generalize dependent b.
  generalize dependent y.
  induction n1; intros.
  simpl.
  exists b, y. auto.
  destruct y.
  simpl in H. lia.
  simpl.
  simpl in H.
  enough (n1 <= length y).
  apply IHn1 with (b:=b0) in H0.
  destruct H0.
  destruct H0.
  rewrite H0.
  exists x,x0. auto.
  lia.
Qed.

Lemma iter_incr1_tail: forall y n,
n <= length y ->
iter (pow 2 n) incr1 y = (incr1 (firstn (length y - n) y)) ++
                          (skipn (length y - n) y) /\
iter (pow 2 n + pow 2 n) incr1 y = (incr2 (firstn (length y - n) y)) ++
                          (skipn (length y - n) y) .
Proof.
    intros.
    generalize dependent y.
    induction n ; intros.
    simpl.
    replace (length y - 0) with (length y).
    rewrite firstn_all_length.
    rewrite skipn_all_length.
    rewrite ?app_nil_r.
    split.
    auto.
    rewrite incr2_incr1. auto.
    lia.

    destruct y.
    simpl.
    simpl in H.
    lia.
    simpl in H.
    simpl.
    replace ((2 ^ n + (2 ^ n + 0))) with (2 ^ n + 2 ^ n ); [| lia].
    split.
    - (*2*)
    assert (iter (2 ^ n + 2 ^ n) incr1 (b::y) = incr2 (firstn (length (b::y) - n) (b::y)) ++ skipn (length (b::y) - n) (b::y)).
    apply IHn.
    simpl. lia.
    rewrite H0.
    remember (length (b :: y) - n).
    remember (length y - n).
    assert (S n1 = n0).
    rewrite Heqn0. rewrite Heqn1. simpl.
    destruct n. lia. lia.
    rewrite <- H1.
    Opaque incr2 incr1.
    simpl.
    Transparent incr2 incr1.
    apply iter_incr1_tail_helper2.
    lia.
    - (*1*)
    rewrite iter_plus.
    assert (iter (2 ^ n + 2 ^ n) incr1 (b::y) = incr2 (firstn (length (b::y) - n) (b::y)) ++ skipn (length (b::y) - n) (b::y)).
    apply IHn.
    simpl. lia.
    rewrite  H0.
    simpl length.
    replace (S (length y) - n) with (S (length y - n)); [|lia].
    simpl firstn.
    simpl skipn.
    remember (incr2 (b :: firstn (length y - n) y) ++ skipn (length y - n) y).
    assert (iter (2 ^ n + 2 ^ n) incr1 l = incr2 (firstn (length l - n) l) ++ skipn (length l - n) l).
    apply IHn.
    all: cycle 1.
    rewrite H1.
    rewrite iter_incr1_tail_helper2 in Heql; [| lia].
    remember (length l - n).
    remember (length y - n).
    rewrite Heql.
    simpl.
    enough (length l > length y) as H10.
    enough (length (skipn n1 (b :: y)) = S n).
    enough (length (incr1 (firstn n1 (b :: y))) = length l - S n).
    enough (exists h t, skipn n1 (b :: y) = h::t).
    destruct H4.
    destruct H4.
    enough (skipn n0 (incr1 (firstn n1 (b :: y)) ++ skipn n1 (b :: y)) = x0).
    rewrite H5.
    enough (firstn n0 (incr1 (firstn n1 (b :: y)) ++ skipn n1 (b :: y)) = incr1 (firstn n1 (b :: y)) ++ [x] ).
    rewrite H6.
    rewrite H4.
    rewrite iter_incr1_tail_helper1.
    rewrite incr2_incr1.
    rewrite app_ass.
    auto.
    remember (incr1 (firstn n1 (b :: y))).
    enough (length b0  = n0 - 1).
    rewrite firstn_app.
    rewrite firstn_all2.
    rewrite H6.
    rewrite H4.
    replace (n0 - (n0 - 1)) with 1.
    simpl. auto.
    enough (n0 >= 1).
    lia.
    subst n0.
    lia.
    lia.
    lia.
    rewrite H4.
    rewrite skipn_app.
    rewrite skipn_all2.
    rewrite H3.
    rewrite Heqn0.
    replace (length l - n - (length l - S n)) with 1.
    simpl. auto.
    lia.
    lia.
    apply iter_incr1_tail_helper3.
    lia.
    assert (length l = length (incr1 (firstn n1 (b :: y))) + S n).
    rewrite Heql.
    rewrite <- H2.
    rewrite app_length. auto.
    lia.
    rewrite Heqn1.
    rewrite skipn_length.
    simpl length.
    lia.
    rewrite Heql.
    rewrite app_length.
    enough (length (incr1 (firstn n1 (b :: y))) >= length (firstn n1 (b :: y))).
    enough  (length ((firstn n1 (b :: y))) + length (skipn n1 (b :: y)) > length y).
    lia.
    rewrite <- app_length.
    rewrite firstn_skipn. simpl. lia.
    apply incr1_length.
    rewrite Heql.
    rewrite app_length.
    enough (length (incr2 (b :: firstn (length y - n) y)) >= length ( (b :: firstn (length y - n) y))) .
    enough (length (incr2 (b :: firstn (length y - n) y)) +
    length (skipn (length y - n) y) >= length y).
    lia.
    enough (length ( (b :: firstn (length y - n) y)) +
    length (skipn (length y - n) y) = S (length y)).
    lia.
    simpl length . simpl.
    rewrite <- app_length.
    rewrite firstn_skipn.
    auto.
    apply incr2_length.
Qed.

Lemma iter_decr1_incr1: forall b n,
iter n decr1 (iter n incr1 b) = b.
Proof.
  intros.
  generalize dependent b.
  induction n; intros.
  simpl. auto.
  rewrite iterS. simpl.
  rewrite IHn.
  rewrite decr1_incr1.
  auto.
Qed.

Lemma iter_incr1_tail1: forall y,
iter (pow 2 (length y)) incr1 y = E1::y.
Proof.
  intros.
  remember (iter_incr1_tail y (length y)).
  assert (iter (2 ^ length y) incr1 y = incr1 (firstn (length y - length y) y) ++ skipn (length y - length y) y).
  apply a. lia.
  rewrite H.
  replace (length y - length y)  with 0.
  simpl. auto.
  lia.
Qed.

Lemma iter_incr1_tail2: forall y,
iter (pow 2 (length y) + pow 2 (length y)) incr1 y = E2::y.
Proof.
  intros.
  remember (iter_incr1_tail y (length y)).
  assert (iter (2 ^ length y + 2 ^ length y) incr1 y =
  incr2 (firstn (length y - length y) y) ++ skipn (length y - length y) y).
  apply a. lia.
  rewrite H.
  replace (length y - length y)  with 0.
  simpl. auto.
  lia.
Qed.

Lemma remove_head1: forall b y, exists n,
  iter n decr1 (b::y) = y.
Proof.
  intros.
  destruct b.
  exists (2^(length y)).
  rewrite <- iter_incr1_tail1.
  rewrite iter_decr1_incr1. auto.
  exists (2^(length y) + 2^(length y)).
  rewrite <- iter_incr1_tail2.
  rewrite iter_decr1_incr1. auto.
Qed.

Lemma skipn_n: forall {X} (b : list X),
  skipn (length b - 0) b = [] .
Proof.
  induction b.
  auto.
  simpl.
  rewrite PeanoNat.Nat.sub_0_r  with (length b) in IHb.
  auto.
Qed.

Lemma firstn_n: forall {X} (b : list X),
  firstn (length b) b = b.
Proof.
  induction b.
  auto.
  simpl.
  rewrite IHb. auto.
Qed.

Lemma decr1_E2_snoc_length: forall x,
true = (length (decr1 (x ++ [E2])) =? length (x ++ [E2])).
Proof.
  intros.

  induction x using list_ind_length.
  simpl. auto.
  destruct x. simpl. auto.
  simpl.

  rewrite <- H.

  remember (snoc_cons x E2). clear Heqe.
  inversion_clear e. inversion_clear H0.
  rewrite H1.
  destruct b.
  rewrite <- H1.
  simpl. auto.
  rewrite <- H1.
  simpl. auto.
  simpl. lia.
Qed.

(* #[ using = "snoc_cons" ] *)
Lemma decr1_E2_snoc: forall x, decr1 (x ++ [E2]) = x ++ [E1].
Proof.
  intros.
  induction x using list_ind_length.
  simpl. auto.
  destruct x. simpl. auto.
  simpl.
  replace (length (decr1 (x ++ [E2])) =? length (x ++ [E2])) with true.
  remember (snoc_cons x E2).
  clear Heqe.
  inversion_clear e.
  inversion_clear H0.
  rewrite H1.
  rewrite <- H1.
  rewrite H.
  destruct b; auto.
  simpl. lia.
  apply decr1_E2_snoc_length.
Qed.

Lemma incr1_E1_snoc: forall x, incr1 (x ++ [E1]) = x ++ [E2].
Proof.
  intros.
  rewrite <- decr1_E2_snoc.
  apply incr1_decr1.
  rewrite app_length.
  simpl. lia.
Qed.

Lemma decr1_E1_snoc: forall x,
0 < length x ->
decr1 (x ++ [E1]) = (decr1 x) ++ [E2].
Proof.
  intros.
  induction x using list_ind_length.
  simpl in H. lia.

  destruct x. simpl in H. lia.
  simpl.
  remember (snoc_cons x E1).
  clear Heqe.
  inversion_clear e.
  inversion_clear H1.
  rewrite H2.
  rewrite <- H2.
  remember (length (decr1 (x ++ [E1])) =? length (x ++ [E1])).
  remember (length (decr1 x) =? length x).
  destruct b. destruct b0. destruct x. simpl.
  simpl in Heqb0. discriminate.
  destruct b1.
  rewrite H0. auto.
  simpl. lia. simpl. lia.
  exfalso.
  rewrite H0 in Heqb0.
  rewrite ?app_length in Heqb0.
  remember (b::x).
  simpl in Heqb0.
  symmetry in Heqb0.
  apply PeanoNat.Nat.eqb_eq in Heqb0.
  replace (length (decr1 l)) with (length l) in Heqb1.
  symmetry in Heqb1.
  rewrite PeanoNat.Nat.eqb_refl in Heqb1.
  discriminate.
  lia.
  simpl. lia.
  simpl. lia.
  destruct x.
  simpl. auto.
  destruct b1.
  exfalso.
  rewrite H0 in Heqb0.
  rewrite ?app_length in Heqb0.
  remember (b::x).
  simpl in Heqb0.
  symmetry in Heqb0.
  apply PeanoNat.Nat.eqb_neq in Heqb0.
  replace (length (decr1 l)) with (length l) in Heqb0.
  contradiction.
  apply PeanoNat.Nat.eqb_eq.
  rewrite Heqb1.
  apply PeanoNat.Nat.eqb_sym.
  simpl. lia.
  simpl. lia.
  rewrite H0.
  auto.
  simpl. lia.
  simpl. lia.
  destruct b0.
  destruct x.
  simpl.
  simpl in Heqb0. discriminate.
  destruct b1.
  rewrite H0. auto.
  simpl. lia.
  simpl. lia.
  exfalso.
  rewrite H0 in Heqb0.
  rewrite ?app_length in Heqb0.
  remember (b::x).
  replace (length (decr1 l)) with (length l) in Heqb1.
  rewrite PeanoNat.Nat.eqb_refl in Heqb1.
  discriminate.
  simpl in Heqb0.
  symmetry in Heqb0.
  apply PeanoNat.Nat.eqb_eq in Heqb0.
  lia.
  simpl. lia.
  simpl. lia.
  destruct x.
  simpl. auto.
  destruct b1.
  exfalso.
  rewrite H0 in Heqb0.
  remember (b::x).
  rewrite ?app_length in Heqb0.
  simpl in Heqb0.
  symmetry in Heqb1.
  apply PeanoNat.Nat.eqb_eq in Heqb1.
  rewrite Heqb1 in Heqb0.
  symmetry in Heqb0.
  rewrite PeanoNat.Nat.eqb_refl in Heqb0.
  discriminate.
  simpl. lia.
  simpl. lia.
  rewrite H0.
  auto.
  simpl. lia.
  simpl. lia.
Qed.

Lemma incr1_E2_snoc: forall x,
incr1 (x ++ [E2]) = (incr1 x) ++ [E1].
Proof.
  intros.
  replace (incr1 x ++ [E1]) with (incr1 (decr1 (incr1 x ++ [E1]))).
  rewrite decr1_E1_snoc.
  rewrite decr1_incr1. auto.
  destruct x.
  simpl. lia.
  simpl.
  destruct b; destruct (length (incr1 x) =? length x); simpl; lia.
  rewrite incr1_decr1. auto.
  rewrite app_length.
  simpl. lia.
Qed.

Lemma decr1_ge2digit: forall a b x, 0 < length (decr1 (a :: b :: x)).
Proof.
  intros.
  remember (decr1 (a::b::x)).
  assert (a :: b :: x = incr1 l).
  rewrite Heql.
  rewrite incr1_decr1.
  auto.
  simpl. lia.
  assert (length l <= length (a::b::x)).
  rewrite H.
  apply incr1_length.
  assert (length l < length (a::b::x) \/ length l = length (a::b::x)).
  lia.
  inversion_clear H1.
  rewrite H in H2.
  apply length_le_S in H2.
  rewrite <- H in H2.
  simpl in H2. lia.
  simpl in H2. lia.
Qed.

Lemma decr2_ge2digit: forall a b x, 0 < length (decr1 (decr1 (a :: b :: x))).
Proof.
  intros.
  remember (decr1 (decr1 (a::b::x))).
  assert (a :: b :: x = incr1 (incr1 l)).
  rewrite Heql.
  repeat rewrite incr1_decr1.
  auto.
  simpl. lia.
  apply decr1_ge2digit.
  assert (length (incr1 l) <= length (a::b::x)).
  rewrite H.
  apply incr1_length.
  assert (length l  <= length (incr1 l)).
  apply incr1_length.
  assert (length l < length (incr1 l) \/ length l = length (incr1 l)).
  lia.
  assert (length (incr1 l) < length (a :: b :: x) \/ length (incr1 l) = length (a::b::x)).
  lia.
  clear H0 H1.
  inversion_clear H2; inversion_clear H3.
  - apply incr1_cons1 in H0.
  rewrite H in H1.
  apply incr1_cons2 in H1.
  exfalso.
  destruct (incr1 l).
  inversion H.
  inversion H0. inversion H1.
  rewrite <- H4 in H8.
  discriminate.
  - simpl in H1.
  apply length_le_S in H0.
   lia.
  - rewrite H in H1.
  apply length_le_S in H1.
  rewrite <- H in H1.
  simpl in H1.
   lia.
  - simpl in H1.
  lia.
Qed.

Lemma firstn_snoc: forall {X} x m (a:X),
m <= length x ->
firstn m x = firstn m (x ++ [a]).
Proof.
  intros.
  generalize dependent x.
  generalize dependent a.
  induction m; intros.
  simpl. auto.
  destruct x. simpl in H. lia.
  simpl in H.
  assert (m <= length x0) by  lia.
  simpl.
  erewrite IHm.
  reflexivity. auto.
Qed.

Lemma skipn_snoc: forall {X} x m (a:X),
m <= length x ->
skipn m (x++[a]) = skipn m x ++ [a].
Proof.
  intros.
  generalize dependent x.
  generalize dependent a.
  induction m; intros.
  simpl. auto.
  destruct x. simpl in H. lia.
  simpl in H.
  assert (m <= length x0) by  lia.
  simpl.
  erewrite IHm.
  reflexivity. auto.
Qed.

Lemma decr1_nil: forall b, decr1 b = [] ->  b = [] \/ b = [E1].
Proof.
  intros.
  destruct b. left. auto.
  destruct b0.
  destruct b. right. auto.
  discriminate.
  remember (decr1_ge2digit b b0 b1).
  clear Heql.
  rewrite H in l.
  simpl in l. lia.
Qed.

Lemma incr1_cons1_inv: forall b,
Forall (eq E1) (incr1 b) -> length b  < length (incr1 b).
Proof.
  intros.
  induction b using list_ind_length.
  simpl. lia.
  destruct b.
  simpl. lia.
  remember (cons_snoc b0 b).
  clear Heqe.
  inversion_clear e. inversion_clear H1.
  rewrite <- H2 in H.
  destruct x.
  -
  rewrite incr1_E1_snoc in H.
  exfalso.
  revert H.
  generalize x0.
  intros.
  induction x1.
  inversion H. discriminate.
  inversion H.
  apply IHx1. auto.
  -
  rewrite incr1_E2_snoc in H.
  rewrite <- H2.
  rewrite incr1_E2_snoc.

  enough (Forall (eq E1) (incr1 x0)).
  apply H0 in H1.
  rewrite ?app_length.
  simpl. lia.
  rewrite <- H2.
  rewrite app_length.
  simpl. lia.

  remember (incr1 x0).
  revert H.
  generalize b1.
  intros.
  induction b2.
  auto.
  inversion H.
  constructor. auto.
  apply IHb2.
  auto.
Qed.

Lemma decr1_in_tail: forall l b b',
l ++ b = decr1 (l ++ b') ->
b = decr1 b'.
Proof.
  intros.
  generalize dependent b.
  generalize dependent b'.
  induction l using list_ind_length; intros.
  simpl in H.
  auto.
  destruct l.
  auto.

  simpl in H0.
  destruct b0.
  -
  remember (l++b').
  destruct l0.
  +
  discriminate.
  +
  remember (length (decr1 (b0 :: l0)) =? length (b0 :: l0)).
  destruct b1.
  Opaque decr1.
  inversion H0.
  Transparent decr1.
  rewrite Heql0 in H2.
  apply H in H2.
  auto.
  simpl. lia.
  Opaque decr1.
  inversion H0.
  Transparent decr1.
  -
  remember (l++b').
  destruct l0.
  +
  discriminate.
  +
  remember (length (decr1 (b0 :: l0)) =? length (b0 :: l0)).
  destruct b1.
  Opaque decr1.
  inversion H0.
  Transparent decr1.
  rewrite Heql0 in H2.
  apply H in H2.
  auto.
  simpl. lia.
  Opaque decr1.
  inversion H0.
  Transparent decr1.
Qed.

Lemma decr1_cons1: forall b, length (decr1 b) < length b ->  Forall (eq E1) b.
Proof.
  intros.
  destruct b.
  auto.
  remember (b::b0).
  replace l with (incr1(decr1 l)).
  apply incr1_cons1.
  rewrite incr1_decr1.
  auto.
  rewrite Heql.
  simpl. lia.
  apply incr1_decr1.
  rewrite Heql. simpl. lia.
Qed.

Lemma decr1_cons1_inv: forall b,
0 < length b ->
Forall (eq E1) b -> length (decr1 b) < length b .
Proof.
  intros.
  destruct b.
  auto.
  remember (b::b0).
  remember (decr1 l).
  enough (l = incr1 l0).
  rewrite H1.
  rewrite H1 in H0.
  apply incr1_cons1_inv.
  auto.
  rewrite Heql0.
  symmetry.
  apply incr1_decr1.
  rewrite Heql. simpl. lia.
Qed.

Lemma decr1_cons2_inv: forall b,
0 < length b ->
Forall (eq E2) (decr1 b) -> length (decr1 b) < length b .
Proof.
  intros.
  destruct b.
  auto.
  remember (b::b0).
  remember (decr1 l).
  enough (l = incr1 l0).
  rewrite H1.
  apply incr1_cons2_inv.
  auto.
  rewrite Heql0.
  symmetry.
  apply incr1_decr1.
  rewrite Heql. simpl. lia.
Qed.

Lemma decr1_cons2: forall b, length (decr1 b) < length b ->  Forall (eq E2) (decr1 b).
Proof.
  intros.
  destruct b.
  simpl. auto.
  remember (decr1 (b :: b0)).
  apply incr1_cons2.
  rewrite Heql.
  rewrite incr1_decr1.
  rewrite Heql in H.
  auto.
  simpl. lia.
Qed.

Lemma decr1_length_plus : forall b : list binary,
length (decr1 b) < length b -> S (length (decr1 b)) = length b .
Proof.
  intros.
  remember (decr1 b).
  destruct b.
  simpl in H. lia.
  remember (b::b0).
  enough (l0 = incr1 l).
  rewrite H0.
  apply incr1_length_plus.
  rewrite H0 in H.
  auto.
  rewrite Heql.
  symmetry.
  apply incr1_decr1.
  rewrite Heql0.
  simpl. lia.
Qed.

Lemma ForallE2_not_ForallE1_decr1: forall b,
1 < length b ->
Forall (eq E2) b ->
~ Forall (eq E1) (decr1 b).
Proof.
  intros.
  unfold not.
  intros.
  induction b using list_ind_length.
  simpl in H. lia.
  destruct b.
  simpl in H. lia.
  destruct b0.
  simpl in H. lia.
  simpl in H1.
  inversion H0.
  inversion H6.
  rewrite <- H5 in H1.
  rewrite <- H9 in H1.
  destruct b1.
  simpl in H1.
  inversion H1.
  discriminate.
  rewrite <- H8 in H1.
  remember (length (decr1 l0) =? length l0).
  destruct b3.
  remember (length (E2 :: decr1 l0) =? S (length l0)).
  destruct b3.
  inversion H1.
  discriminate.
  inversion_clear H1.
  inversion_clear H12.
  discriminate.
  remember (length (E1 :: E2 :: decr1 l0) =? S (length l0)).
  destruct b3.
  inversion H1.
  discriminate.
  inversion H1.
  inversion H14.
  discriminate.
Qed.

Lemma decr1_ltlength_S : forall b,
false = (length (decr1 b) =? length b) ->
S (length (decr1 b)) = length b.
Proof.
  intros.
  apply decr1_length_plus.
  enough (length (decr1 b) < length b \/ length (decr1 b) = length b).
  inversion_clear H0; auto.
  exfalso.
  rewrite H1 in H.
  rewrite PeanoNat.Nat.eqb_refl in H.
  discriminate.
  enough (length (decr1 b) <= length b).
  lia.
  apply decr1_length.
Qed.

Lemma decr1_special: forall b b',
length b = length b' ->
Forall (eq E2) b ->
Forall (eq E1) b' ->
E1 :: b = decr1 (E2 :: b').
Proof.
  intros.
  generalize dependent b.
  induction b' using list_ind_length; intros.
  destruct b; auto.
  simpl in H. lia.

  destruct b'; destruct b; auto.
  simpl in H0. lia.
  simpl in H0. lia.
  inversion H1.
  rewrite <- H5.
  inversion H2.
  rewrite <- H9.
  simpl.

  destruct b'.
  simpl.
  assert (b1=[]).
  destruct b1; auto.
  simpl in H0. lia.
  rewrite H11.
  auto.

  rewrite <- H4 in *.
  enough (S (length (decr1 l)) = length l).
  rewrite <- H11.

  replace (length (decr1 l) =? S (length (decr1 l))) with false.
  simpl.
  replace (length (decr1 l) =? S (length (decr1 l))) with false.

  enough (E2 :: b1 = E2 :: E2 :: decr1 l).
  rewrite H12. auto.
  apply Forall_eq with (x1:=E2).
  simpl.
  rewrite H11.
  simpl in H0. auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  apply decr1_cons2.
  apply decr1_cons1_inv; auto.
  rewrite H4. simpl. lia.
  symmetry.
  apply PeanoNat.Nat.eqb_neq.
  lia.
  symmetry.
  apply PeanoNat.Nat.eqb_neq.
  lia.
  apply decr1_length_plus.
  apply decr1_cons1_inv; auto.
  rewrite H4. simpl. lia.
Qed.

Lemma decr1_special2: forall b b',
length b = length b' ->
Forall (eq E2) b ->
Forall (eq E1) b' ->
E1 :: E1 :: b = decr1 (E1 :: E2 :: b').
Proof.
  intros.
  generalize dependent b.
  induction b' using list_ind_length; intros.
  destruct b; auto.
  simpl in H. lia.

  destruct b'; destruct b; auto.
  simpl in H0. lia.
  simpl in H0. lia.
  inversion H1.
  rewrite <- H5.
  inversion H2.
  rewrite <- H9.
  simpl.

  destruct b'.
  simpl.
  assert (b1=[]).
  destruct b1; auto.
  simpl in H0. lia.
  rewrite H11.
  auto.

  rewrite <- H4 in *.
  enough (S (length (decr1 l)) = length l).
  rewrite <- H11.

  replace (length (decr1 l) =? S (length (decr1 l))) with false.
  simpl.
  replace (length (decr1 l) =? S (length (decr1 l))) with false.

  simpl.
  rewrite PeanoNat.Nat.eqb_refl.

  enough ( E2 :: b1 = E2 :: E2 :: decr1 l).
  rewrite H12. auto.
  apply Forall_eq with (x1:=E2).
  simpl.
  rewrite H11.
  simpl in H0. auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  apply decr1_cons2.
  apply decr1_cons1_inv; auto.
  rewrite H4. simpl. lia.
  symmetry.
  apply PeanoNat.Nat.eqb_neq.
  lia.
  symmetry.
  apply PeanoNat.Nat.eqb_neq.
  lia.
  apply decr1_length_plus.
  apply decr1_cons1_inv; auto.
  rewrite H4. simpl. lia.
Qed.

Lemma decr1_special3: forall b b',
length b = length b' ->
Forall (eq E2) b ->
Forall (eq E1) b' ->
b = decr1 (E1 :: b').
Proof.
  intros.

  generalize dependent b.
  induction b' using list_ind_length; intros.
  destruct b; auto.
  simpl in H. lia.

  destruct b'; destruct b; auto.
  simpl in H0. lia.
  simpl in H0. lia.
  inversion H1.
  rewrite <- H5.
  inversion H2.
  rewrite <- H9.

  simpl.
  destruct b'.
  simpl.
  assert (b1=[]).
  destruct b1; auto.
  simpl in H0. lia.
  rewrite H11.
  auto.

  rewrite <- H4 in *.
  enough (S (length (decr1 l)) = length l).
  rewrite <- H11.

  replace (length (decr1 l) =? S (length (decr1 l))) with false.
  simpl.
  replace (length (decr1 l) =? S (length (decr1 l))) with false.

  enough (b1 = E2 :: decr1 l).
  rewrite H12. auto.
  apply Forall_eq with (x1:=E2).
  simpl.
  rewrite H11.
  simpl in H0. lia.
  auto.
  constructor; auto.
  apply decr1_cons2.
  apply decr1_cons1_inv; auto.
  rewrite H4. simpl. lia.
  symmetry.
  apply PeanoNat.Nat.eqb_neq.
  lia.
  symmetry.
  apply PeanoNat.Nat.eqb_neq.
  lia.
  apply decr1_length_plus.
  apply decr1_cons1_inv; auto.
  rewrite H4. simpl. lia.
Qed.

Lemma decr_iter_comm: forall (a : bilist) (n : nat),
  decr1 (iter n decr1 a) = iter n decr1 (decr1 a).
Proof.
  intros.
  generalize dependent a.
  induction n.
  auto.
  intros.
  simpl.
  rewrite IHn.
  auto.
Qed.


Require Import compcert.lib.Coqlib Lia.

(* Ltac by Andrew Appel *)
Ltac do_range H tac :=
  match type of H with
    | ?lo <= ?i < ?hi =>
      try lia;
    let H' := fresh in let H'' := fresh in
                       destruct (zlt lo i) as [H' | H'];
    [ assert (H'' : lo + 1 <= i < hi) by lia;
      simpl in H'';
      clear H H'; rename H'' into H;
      try do_range H tac
    | try (assert (i = lo) by lia; subst i; tac)
    ]
  end.

Lemma test : forall i,
               0 <= i < 256 -> i + 1 > i.
Proof.
  intros.
  do_range H lia.             (* could use simpl; reflexivity, etc. *)
Qed.


(* A functional Schreier-vector to compute orbits. *)

From CGT Require Import A1_setup A2_lists B1_fmap B2_perm B3_word B4_group.

Module Schreier.
Section Vector.

Definition vector := fmap perm.

(* Add all numbers reachable from i. *)
Fixpoint extend (i : positive) (π : perm)
  (gen : list perm) (V : vector)
  (new : list positive) :=
  match gen with
  | [] => (V, new)
  | σ :: gen' =>
    let j := σ⋅i in
    match lookup V j with
    | Some _ => extend i π gen' V new
    | None => extend i π gen' (insert V j (σ ∘ π)) (j :: new)
    end
  end.

(* The generating set. *)
Variable gen : list perm.

(* Extend all numbers in the source list. *)
Fixpoint extend_loop (V : vector) (try new : list positive) :=
  match try with
  | [] => (V, new)
  | i :: try' =>
    match lookup V i with
    | None => extend_loop V try' new
    | Some π =>
      match extend i π gen V new with
      | (V', new') => extend_loop V' try' new'
      end
    end
  end.

(* Repeat orbit extension n times. *)
Fixpoint loop (V : vector) (try : list positive) (n : nat) :=
  match n with
  | O => V
  | S m =>
    match extend_loop V try [] with
    | (V', []) => V'
    | (V', new) => loop V' new m
    end
  end.

(* The stabilizer point. *)
Variable k : positive.

(* Build an orbit vector given an orbit size bound. *)
(* Note that it doesn't make a difference if the bound is bigger than needed. *)
Definition build (bound : nat) := loop (insert Leaf k ident) [k] bound.

(* The orbit given by they keys of the Schreier vector. *)
Definition orbit (V : vector) : list positive := map fst (entries V xH).

(* The subgroup generators according to Schreier's Lemma. *)
Definition generators (V : vector) : list perm :=
  let ϕ := mapval inv V in map
  (λ σ_u, let σu := fst σ_u ∘ snd σ_u in (lookup ϕ σu⋅k ?? ident) ∘ σu)
  (list_prod gen (values V)).

(***
Theorems
*)

Hypothesis perms : Forall Perm gen.

Ltac replace_fst x y E := replace x with (fst (x, y)) by easy; rewrite <-E.
Ltac replace_snd x y E := replace y with (snd (x, y)) by easy; rewrite <-E.

Section Generic.

Open Scope nat.

Variable P : vector -> Prop.
Hypothesis prop_extend_loop :
  ∀V try new, P V -> P (fst (extend_loop V try new)).

Lemma prop_loop V try n :
  P V -> P (loop V try n).
Proof.
revert V try; simple_ind n.
destruct extend_loop as [V' new] eqn:E.
replace_fst V' new E; destruct new; [|apply IHn].
all: apply prop_extend_loop, H.
Qed.

Lemma prop_loop_le V try m n :
  P (loop V try m) -> m <= n -> P (loop V try n).
Proof.
revert V try n; induction m; simpl; intros.
apply prop_loop, H. destruct n; [easy|simpl].
destruct extend_loop as [V' new] eqn:E.
destruct new; [easy|]. apply IHm. easy. apply le_S_n, H0.
Qed.

End Generic.

Section Soundness.

(* The orbit permutations are valid. *)
Definition Sound (V : vector) :=
  ∀i π, lookup V i = Some π -> Generates gen π /\ π⋅k = i.

Lemma sound_extend π gen' V new :
  Generates gen π -> gen' ⊆ gen ->
  Sound V -> Sound (fst (extend π⋅k π gen' V new)).
Proof.
revert V new; simple_ind gen'.
apply incl_cons_inv in H0 as [].
destruct lookup; apply IHgen'; try easy.
intros j; rewrite lookup_insert; destruct (_ =? _) eqn:E.
convert_bool; subst; split; inv H3. apply generates_compose.
easy. apply generates_generator; easy. apply apply_compose.
apply H1.
Qed.

Lemma sound_extend_loop V try new :
  Sound V -> Sound (fst (extend_loop V try new)).
Proof.
revert V new; simple_ind try.
destruct (lookup V a) eqn:E.
destruct extend as [V' new'] eqn:E'.
replace_fst V' new' E'. all: apply IHtry; try easy.
apply H in E as []; subst. apply sound_extend; easy.
Qed.

Theorem sound_build bound :
  Sound (build bound).
Proof.
unfold build; apply prop_loop. apply sound_extend_loop.
intros i; rewrite lookup_insert; simpl.
destruct (k =? i) eqn:E; [convert_bool; subst; intros|easy].
inv H; split. apply generates_ident. easy.
Qed.

End Soundness.

Section Completeness.

Local Open Scope nat.

(* The vector contains the full orbit. *)
Definition Complete (V : vector) := ∀π, Generates gen π -> Defined V π⋅k.

(* The vector and the new points are an intermediary result. *)
Definition Intermediate (V : vector) new :=
  Forall (λ i, Defined V i) new /\
  ∀i, Defined V i -> In i new \/ ∀σ, In σ gen -> Defined V σ⋅i.

Lemma lookup_extend j π gen' V new i τ :
  lookup V i = Some τ -> lookup (fst (extend j π gen' V new)) i = Some τ.
Proof.
revert V new; simple_ind gen'.
destruct (lookup V a⋅j) eqn:E; erewrite <-IHgen'; try easy.
rewrite lookup_insert; destruct (_ =? _)%positive eqn:E'; convert_bool.
rewrite E', H in E; easy. easy.
Qed.

Lemma lookup_extend_loop V try new i τ :
  lookup V i = Some τ -> lookup (fst (extend_loop V try new)) i = Some τ.
Proof.
revert V new; simple_ind try.
destruct (lookup V a) eqn:E. destruct extend as [V' new'] eqn:E'.
replace_fst V' new' E'. all: apply IHtry; try easy.
apply lookup_extend; easy.
Qed.

Lemma defined_extend i j π gen' V new :
  Defined V i -> Defined (fst (extend j π gen' V new)) i.
Proof.
destruct (lookup V i) eqn:E; [intros _|easy].
erewrite lookup_extend. easy. apply E.
Qed.

Lemma defined_extend_loop V try new i :
  Defined V i -> Defined (fst (extend_loop V try new)) i.
Proof.
destruct (lookup V i) eqn:E; [intros _|easy].
erewrite lookup_extend_loop. easy. apply E.
Qed.

Lemma not_new_extend i j π gen' V new :
  Defined V i -> ¬In i new -> ¬In i (snd (extend j π gen' V new)).
Proof.
revert V new; simple_ind gen'.
destruct (lookup V a⋅j) eqn:E; apply IHgen'; try easy.
apply defined_before_insert, H. intros []; [subst|easy].
rewrite E in H; easy.
Qed.

Lemma not_new_extend_loop V try new i :
  Defined V i -> ¬In i new -> ¬In i (snd (extend_loop V try new)).
Proof.
revert V new; simple_ind try. destruct (lookup V a) eqn:E.
destruct extend as [V' new'] eqn:E'. all: apply IHtry; try easy.
replace_fst V' new' E'; apply defined_extend; easy.
replace_snd V' new' E'; apply not_new_extend; easy.
Qed.

Lemma intermediate_extend try i π gen' V new V' new' :
  extend i π gen' V new = (V', new') ->
  gen' ⊆ gen -> (∀σ, In σ gen -> ¬In σ gen' -> Defined V σ⋅i) ->
  Intermediate V (i :: try ++ new) -> Intermediate V' (try ++ new').
Proof.
revert V new; induction gen'; simpl; intros.
- inv H; destruct H2. split. inv H. intros.
  apply H2 in H3 as []. inv H3.
  right; intros; apply H1; easy.
  left; easy. right; easy.
- apply incl_cons_inv in H0.
  destruct lookup eqn:E; eapply IHgen' in H; try easy; intros.
  + destruct (ffun_eq_dec a σ); subst. rewrite E; easy.
    apply H1. easy. intros []; easy.
  + destruct (ffun_eq_dec a σ); subst. rewrite lookup_insert_eq; easy.
    apply defined_before_insert, H1. easy. intros []; easy.
  + (* Here we show that the insertion produces a new intermediate vector. *)
    destruct H2. rewrite app_comm_cons in H2; apply Forall_app in H2. split.
    * apply Forall_app with (l1:=i :: try); split.
      2: apply Forall_cons. 2: rewrite lookup_insert_eq; easy.
      all: eapply Forall_impl; [|apply H2].
      all: intros; apply defined_before_insert; easy.
    * intros. rewrite lookup_insert in H4.
      destruct (_ =? _)%positive eqn:E'; convert_bool; subst.
      left; auto with datatypes. apply H3 in H4 as [].
      left; rewrite app_comm_cons; apply in_app_comm, in_cons, in_app_comm, H4.
      right; intros; apply defined_before_insert, H4, H5.
Qed.

Lemma intermediate_extend_loop V try new V' try' :
  extend_loop V try new = (V', try') ->
  Intermediate V (try ++ new) -> Intermediate V' try'.
Proof.
revert V new; induction try; simpl; intros. inv H.
assert(Defined V a) by (destruct H0; inv H0).
destruct (lookup V a) eqn:E; [|easy].
destruct extend as [V'' new'] eqn:E'.
eapply IHtry. apply H. eapply intermediate_extend.
apply E'. all: easy.
Qed.

Lemma intermediate_finished V w i :
  Intermediate V [] -> Defined V i -> w ⊆ gen -> Defined V (apply' w i).
Proof.
intros [_ H]; revert i; simple_ind w.
apply incl_cons_inv in H1 as []. apply IHw.
apply H in H0 as []; [easy|apply H0, H1]. easy.
Qed.

Lemma complete_loop V try i w :
  w ⊆ gen -> Intermediate V try -> Defined V i ->
  Defined (loop V try (length w)) (apply' w i).
Proof.
revert V try i; induction w as [|σ w]; [easy|intros; simpl loop].
destruct extend_loop as [V' new] eqn:E. assert(Intermediate V' new).
eapply intermediate_extend_loop. apply E. rewrite app_nil_r; easy.
eapply defined_extend_loop in H1 as H3; rewrite E in H3; simpl in H3.
eapply not_new_extend_loop in H1 as H4; [rewrite E in H4; simpl in H4|easy].
destruct new as [|j new]. apply intermediate_finished; easy.
apply incl_cons_inv in H. simpl; apply IHw; try easy.
destruct H2 as [_ ?]; apply H2 in H3 as []; [easy|].
apply H3; easy.
Qed.

Theorem complete_build n :
  size (put k (union_range gen)) <= n -> Complete (build n).
Proof.
intros H π [w []]; unfold build.
destruct (short_connecting_word w k) as [w' [? []]].
assert(w' ⊆ gen) by eauto with datatypes.
rewrite H1, apply_compose', <-H4. eapply prop_loop_le.
intros; apply defined_extend_loop; easy.
apply complete_loop. easy.
- split. apply Forall_cons. rewrite lookup_insert_eq; easy. auto.
  intros. rewrite lookup_insert in H6.
  destruct (k =? i)%positive eqn:E; [|easy].
  convert_bool; subst; left; apply in_eq.
- rewrite lookup_insert_eq; easy.
- etransitivity; [|apply H]. rewrite size_eq_length_values.
  replace (length w') with (length (path w' k)) at 1.
  apply NoDup_incl_length. easy. apply path_range, H5.
  unfold path; rewrite map_length, seq_length; easy.
Qed.

Theorem lookup_ident n :
  lookup (build n) k = Some ident.
Proof.
unfold build; apply prop_loop.
intros; apply lookup_extend_loop; easy.
apply lookup_insert_eq.
Qed.

End Completeness.

Section Schreiers_lemma.

Variable V : vector.

Notation ϕ π := (lookup V π⋅k ?? ident).

Lemma lookup_mapval_inv π :
  lookup (mapval inv V) π⋅k ?? ident = inv (ϕ π).
Proof.
destruct (lookup V π⋅k) eqn:E.
erewrite lookup_mapval_some; easy.
rewrite lookup_mapval_none; easy.
Qed.

Theorem in_generators σ u :
  In σ gen -> In u (values V) ->
  let σu := σ ∘ u in let π := inv (ϕ σu) ∘ σu in In π (generators V).
Proof.
intros; apply in_map_iff; exists (σ, u); simpl; split.
rewrite lookup_mapval_inv; easy. apply in_prod; easy.
Qed.

Hypothesis sound : Sound V.

Lemma generates_vector_words w :
  In w (values V) -> Generates gen w.
Proof.
intros; apply in_values_lookup in H as [i ?].
apply sound in H; easy.
Qed.

Theorem in_generators_inv π :
  In π (generators V) -> ∃τ, Generates gen τ /\ π == inv (ϕ τ) ∘ τ.
Proof.
intros H; apply in_map_iff in H as [[σ u] []]; exists (σ ∘ u); split.
apply in_prod_iff in H0 as []; apply generates_compose.
apply generates_vector_words, H1. apply generates_generator; easy.
simpl in H; rewrite lookup_mapval_inv in H; rewrite H; easy.
Qed.

Lemma generates_vector_lookup π :
  Generates gen (ϕ π).
Proof.
destruct lookup eqn:E.
eapply sound, E. apply generates_ident.
Qed.

Hypothesis complete : Complete V.

Lemma vector_lookup_spec π :
  Generates gen π -> (ϕ π)⋅k = π⋅k.
Proof.
intros H; apply complete in H.
destruct (lookup V π⋅k) eqn:E; [|easy].
apply sound, E.
Qed.

Hypothesis k_ident : lookup V k = Some ident.

Lemma ident_in_vector :
  In ident (values V).
Proof.
eapply lookup_in_values, k_ident.
Qed.

Lemma vector_lookup_values π :
  In (ϕ π) (values V).
Proof.
destruct (lookup V π⋅k) eqn:E.
eapply lookup_in_values, E. apply ident_in_vector.
Qed.

Theorem generates_generators :
  Forall (Generates gen) (generators V).
Proof.
apply Forall_forall; intros.
apply in_generators_inv in H as [τ []].
eapply generates_subst; [apply H0|].
apply generates_compose; [easy|].
apply generates_inv; [easy|apply generates_vector_lookup].
Qed.

Theorem generators_stable π :
  Generates (generators V) π -> π⋅k = k.
Proof.
intros [w []]; rewrite H0; clear H0.
simple_ind w; rewrite apply_compose.
apply incl_cons_inv in H as []; apply IHw in H0; rewrite <-H0 at 2.
apply in_generators_inv in H as [τ []]; rewrite H1, apply_compose.
rewrite perm_inv_apply with (i:=k). easy. eapply generates_perm.
apply perms. apply generates_vector_lookup.
apply vector_lookup_spec, H.
Qed.

Definition translate :=
  fold_left (λ (u_w' : perm × list perm) σ,
    let (u, w') := u_w' in
    let σu := σ ∘ u in
    let u' := lookup V σu⋅k ?? ident in
    (u', w' ++ [(inv u' ∘ σu)])).

Theorem translate_fst_spec u u' w w' :
  In u (values V) -> w ⊆ gen ->
  fst (translate w (u, w')) = u' ->
  u'⋅k = apply' w u⋅k /\ In u' (values V).
Proof.
revert u w'; induction w; simpl; intros. subst; easy.
apply incl_cons_inv in H0. assert(Generates gen (a ∘ u)).
apply generates_compose. apply generates_vector_words, H.
apply generates_generator; easy.
apply IHw in H1 as []. split; [|easy].
rewrite H1, vector_lookup_spec, apply_compose; easy.
apply vector_lookup_values. easy.
Qed.

Lemma translate_subst_word u w w' w'' :
  fst (translate w (u, w')) = fst (translate w (u, w'')).
Proof.
revert u w' w''; simple_ind w; apply IHw.
Qed.

Lemma translate_shift_word u w w' :
  snd (translate w (u, w')) = w' ++ snd (translate w (u, [])).
Proof.
revert u w'; induction w; simpl; intros. rewrite app_nil_r; easy.
rewrite IHw with (w' := [_]), IHw, app_assoc; easy.
Qed.

Lemma translate_remove_word u u' w w' w'' :
  translate w (u, w') = (u', w' ++ w'') ->
  translate w (u, []) = (u', w'').
Proof.
intros; assert(snd (translate w (u, w')) = w' ++ w'') by (rewrite H; easy).
rewrite translate_shift_word in H0. apply app_inv_head in H0.
rewrite surjective_pairing at 1; rewrite H0.
erewrite translate_subst_word, H; easy.
Qed.

Theorem translate_snd_spec u u' w w' :
  translate w (u, []) = (u', w') ->
  u' ∘ compose' w' ∘ inv u == compose' w.
Proof.
revert u u' w'; induction w; simpl; intros.
inv H; simpl. admit.
assert(w' = snd (u', w')) by easy; rewrite <-H in H0.
rewrite translate_shift_word in H0; subst w'; simpl.
apply translate_remove_word, IHw in H; remember (snd (translate _ _)) as π.
Admitted.

Theorem generators_incl_translate_snd u w :
  In u (values V) -> w ⊆ gen ->
  snd (translate w (u, [])) ⊆ generators V.
Proof.
revert u; simple_ind w; rewrite translate_shift_word.
apply incl_cons_inv in H0 as []; apply incl_app.
intros i Hi; inv Hi; apply in_generators; easy.
apply IHw. apply vector_lookup_values. easy.
Qed.

Theorem generators_complete π :
  Generates gen π -> π⋅k = k -> Generates (generators V) π.
Proof.
intros [w []] ?; destruct (translate w (ident, [])) as [u' w'] eqn:E.
exists w'; split. replace_snd u' w' E; apply generators_incl_translate_snd.
apply ident_in_vector. easy. apply translate_snd_spec in E as ?; simpl in H2.
etransitivity; [apply H0|etransitivity; [symmetry; apply H2|]].
(* The crux: we can determine that u' = ident. *)
assert(fst (u', w') = u') by easy; rewrite <-E in H3.
apply translate_fst_spec in H3 as []; [|apply ident_in_vector|easy].
replace (ident⋅k) with k in H3 by easy.
rewrite <-apply_compose', <-H0, H1 in H3.
apply in_values_lookup in H4 as [i ?].
apply sound in H4 as H5; destruct H5.
rewrite H6 in H3; subst. rewrite k_ident in H4.
inv H4; rewrite leaf_compose; easy.
Qed.

Corollary generators_spec π :
  Generates (generators V) π <-> Generates gen π /\ π⋅k = k.
Proof.
repeat split; intros.
eapply generates_inclusion. apply generates_generators. apply H.
apply generators_stable, H. apply generators_complete; easy.
Qed.

End Schreiers_lemma.

End Vector.
End Schreier.


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.orders.rings.

Inductive SRpair (SR : Type) := C { pos : SR ; neg : SR }.
Arguments C {SR} _ _.
Arguments pos {SR} _.
Arguments neg {SR} _.

Section semiring_pairs.
Context `{SemiRing SR} `{Apart SR}.
Context `{∀ z, LeftCancellation (+) z}.

Add Ring SR : (rings.stdlib_semiring_theory SR).

(* Equivalence *)
Global Instance SRpair_equiv : Equiv (SRpair SR) | 4 := λ x y, pos x + neg y = pos y + neg x.
Global Instance SRpair_apart `{Apart SR} : Apart (SRpair SR) := λ x y, pos x + neg y ≶ pos y + neg x.

Global Instance SRpair_trivial_apart `{!TrivialApart SR} :  TrivialApart (SRpair SR).
Proof. intros x y. now rapply trivial_apart. Qed.

Instance: Setoid (SRpair SR).
Proof.
  split; red; unfold equiv, SRpair_equiv.
    reflexivity.
   intros. now symmetry.
  intros x y z E E'.
  rewrite commutativity.
  rewrite (commutativity (pos z)).
  apply (left_cancellation (+) (pos y)).
  rewrite 2!associativity.
  rewrite <- E, E'. ring.
Qed.

Instance: Proper ((=) ==> (=) ==> (=)) C.
Proof.
  intros x1 y1 E1 x2 y2 E2. unfold equiv, SRpair_equiv. simpl.
  now rewrite E1, E2.
Qed.

(* injection from SR *)
Global Instance SRpair_inject: Cast SR (SRpair SR) := λ r, C r 0.

Global Instance: Proper ((=) ==> (=)) SRpair_inject.
Proof. intros x1 x2 E. unfold equiv, SRpair_equiv. simpl. now rewrite E. Qed.

(* Relations, operations and constants *)
Global Instance SRpair_plus: Plus (SRpair SR) := λ x y, C (pos x + pos y) (neg x + neg y).
Global Instance SRpair_negate: Negate (SRpair SR) := λ x, C (neg x) (pos x).
Global Instance SRpair_0: Zero (SRpair SR) := ('0 : SRpair SR).
Global Instance SRpair_mult: Mult (SRpair SR) := λ x y, C (pos x * pos y + neg x * neg y) (pos x * neg y + neg x * pos y).
Global Instance SRpair_1: One (SRpair SR) := ('1 : SRpair SR).

Ltac unfolds := unfold SRpair_negate, SRpair_plus, equiv, SRpair_equiv in *; simpl in *.
Ltac ring_on_sr := repeat intro; unfolds; try ring.

Instance: Proper ((=) ==> (=)) SRpair_negate.
Proof.
  intros x y E. unfolds.
  rewrite commutativity, <- E. ring.
Qed.

Instance: Proper ((=) ==> (=) ==> (=)) SRpair_plus.
Proof with try ring.
  intros x1 y1 E1 x2 y2 E2. unfolds.
  transitivity (pos x1 + neg y1 + (pos x2 + neg y2))...
  rewrite E1, E2...
Qed.

Let SRpair_mult_proper_r (x y z : SRpair SR) : x = y → z * x = z * y.
Proof with try ring.
  intros E. unfolds.
  transitivity (pos z * (pos x + neg y) + neg z * (pos y + neg x))...
  transitivity (pos z * (pos y + neg x) + neg z * (pos x + neg y))...
  now rewrite E.
Qed.

Instance: Commutative SRpair_mult.
Proof. repeat intro. ring_on_sr. Qed.

Instance: Proper ((=) ==> (=) ==> (=)) SRpair_mult.
Proof.
  intros x1 y1 E1 x2 y2 E2.
  transitivity (x1 * y2).
   now apply SRpair_mult_proper_r.
  rewrite !(commutativity _ y2).
  now apply SRpair_mult_proper_r.
Qed.

Global Instance: Ring (SRpair SR).
Proof. repeat (split; try apply _); ring_on_sr. Qed.

(* A final word about inject *)
Global Instance: SemiRing_Morphism SRpair_inject.
Proof.
  repeat (constructor; try apply _); try reflexivity.
   intros x y. change (x + y + (0 + 0) = x + y + 0). ring.
  intros x y. change (x * y + (x * 0 + 0 * y) = x * y + 0 * 0 + 0). ring.
Qed.

Global Instance: Injective SRpair_inject.
Proof.
  repeat (constructor; try apply _).
  intros x y. unfolds. now rewrite 2!rings.plus_0_r.
Qed.

Lemma SRpair_splits n m : C n m = 'n + -'m.
Proof. ring_on_sr. Qed.

Global Instance SRpair_le `{Le SR} : Le (SRpair SR) := λ x y, pos x + neg y ≤ pos y + neg x.
Global Instance SRpair_lt `{Lt SR} : Lt (SRpair SR) := λ x y, pos x + neg y < pos y + neg x.
Ltac unfold_le := unfold le, SRpair_le, equiv, SRpair_equiv; simpl.
Ltac unfold_lt := unfold lt, SRpair_lt, equiv, SRpair_equiv; simpl.

Section with_semiring_order.
  Context `{!SemiRingOrder SRle}.

  Instance: Proper ((=) ==> (=) ==> iff) SRpair_le.
  Proof.
    assert (∀ x1 y1 : SRpair SR, x1 = y1 → ∀ x2 y2, x2 = y2 → x1 ≤ x2 → y1 ≤ y2) as E.
     unfold_le. intros [xp1 xn1] [yp1 yn1] E1 [xp2 xn2] [yp2 yn2] E2 F. simpl in *.
     apply (order_reflecting (+ (xp2 + xn1))).
     setoid_replace (yp1 + yn2 + (xp2 + xn1)) with ((yp1 + xn1) + (xp2 + yn2)) by ring.
     rewrite <-E1, E2.
     setoid_replace (xp1 + yn1 + (yp2 + xn2)) with ((yp2 + yn1) + (xp1 + xn2)) by ring.
     now apply (order_preserving _).
    split; repeat intro; eapply E; eauto; symmetry; eauto.
  Qed.

  Instance: Reflexive SRpair_le.
  Proof. intros [? ?]. unfold_le. reflexivity. Qed.

  Instance: Transitive SRpair_le.
  Proof.
    intros [xp xn] [yp yn] [zp zn] E1 E2.
    unfold SRpair_le in *. simpl in *.
    apply (order_reflecting (+ (yn + yp))).
    setoid_replace (xp + zn + (yn + yp)) with ((xp + yn) + (yp + zn)) by ring.
    setoid_replace (zp + xn + (yn + yp)) with ((yp + xn) + (zp + yn)) by ring.
    now apply plus_le_compat.
  Qed.

  Instance: AntiSymmetric SRpair_le.
  Proof.
    intros [xp xn] [yp yn] E1 E2. unfold_le.
    now apply (antisymmetry (≤)).
  Qed.

  Instance: PartialOrder SRpair_le.
  Proof. repeat (split; try apply _). Qed.

  Global Instance: OrderEmbedding SRpair_inject.
  Proof.
    repeat (split; try apply _).
     intros x y E. unfold_le. simpl. now rewrite 2!rings.plus_0_r.
    intros x y E. unfold le, SRpair_le in E. simpl in E. now rewrite 2!rings.plus_0_r in E.
  Qed.

  Instance: ∀ z : SRpair SR, OrderPreserving ((+) z).
  Proof.
    repeat (split; try apply _). unfold_le.
    destruct z as [zp zn]. intros [xp xn] [yp yn] E. simpl in *.
    setoid_replace (zp + xp + (zn + yn)) with ((zp + zn) + (xp + yn)) by ring.
    setoid_replace (zp + yp + (zn + xn)) with ((zp + zn) + (yp + xn)) by ring.
    now apply (order_preserving _).
  Qed.

  Instance: ∀ x y : SRpair SR, PropHolds (0 ≤ x) → PropHolds (0 ≤ y) → PropHolds (0 ≤ x * y).
  Proof.
    intros [xp xn] [yp yn].
    unfold PropHolds. unfold_le. intros E1 E2.
    ring_simplify in E1. ring_simplify in E2.
    destruct (decompose_le E1) as [a [Ea1 Ea2]], (decompose_le E2) as [b [Eb1 Eb2]].
    rewrite Ea2, Eb2. ring_simplify.
    apply compose_le with (a * b).
     now apply nonneg_mult_compat.
    ring.
  Qed.

  Global Instance: SemiRingOrder SRpair_le.
  Proof. apply rings.from_ring_order; apply _. Qed.
End with_semiring_order.

Section with_strict_semiring_order.
  Context `{!StrictSemiRingOrder SRle}.

  Instance: Proper ((=) ==> (=) ==> iff) SRpair_lt.
  Proof.
    assert (∀ x1 y1 : SRpair SR, x1 = y1 → ∀ x2 y2, x2 = y2 → x1 < x2 → y1 < y2) as E.
     unfold_lt. intros [xp1 xn1] [yp1 yn1] E1 [xp2 xn2] [yp2 yn2] E2 F. simpl in *.
     apply (strictly_order_reflecting (+ (xp2 + xn1))).
     setoid_replace (yp1 + yn2 + (xp2 + xn1)) with ((yp1 + xn1) + (xp2 + yn2)) by ring.
     rewrite <-E1, E2.
     setoid_replace (xp1 + yn1 + (yp2 + xn2)) with ((yp2 + yn1) + (xp1 + xn2)) by ring.
     now apply (strictly_order_preserving _).
    split; repeat intro; eapply E; eauto; symmetry; eauto.
  Qed.

  Instance: Irreflexive SRpair_lt.
  Proof. intros [? ?] E. edestruct (irreflexivity (<)); eauto. Qed.

  Instance: Transitive SRpair_lt.
  Proof.
    intros [xp xn] [yp yn] [zp zn] E1 E2.
    unfold SRpair_lt in *. simpl in *.
    apply (strictly_order_reflecting (+ (yn + yp))).
    setoid_replace (xp + zn + (yn + yp)) with ((xp + yn) + (yp + zn)) by ring.
    setoid_replace (zp + xn + (yn + yp)) with ((yp + xn) + (zp + yn)) by ring.
    now apply plus_lt_compat.
  Qed.

  Instance: ∀ z : SRpair SR, StrictlyOrderPreserving ((+) z).
  Proof.
    repeat (split; try apply _). unfold_lt.
    destruct z as [zp zn]. intros [xp xn] [yp yn] E. simpl in *.
    setoid_replace (zp + xp + (zn + yn)) with ((zp + zn) + (xp + yn)) by ring.
    setoid_replace (zp + yp + (zn + xn)) with ((zp + zn) + (yp + xn)) by ring.
    now apply (strictly_order_preserving _).
  Qed.

  Instance: StrictSetoidOrder SRpair_lt.
  Proof. repeat (split; try apply _). Qed.

  Instance: ∀ x y : SRpair SR, PropHolds (0 < x) → PropHolds (0 < y) → PropHolds (0 < x * y).
  Proof.
    intros [xp xn] [yp yn].
    unfold PropHolds. unfold_lt. intros E1 E2.
    ring_simplify in E1. ring_simplify in E2.
    destruct (decompose_lt E1) as [a [Ea1 Ea2]], (decompose_lt E2) as [b [Eb1 Eb2]].
    rewrite Ea2, Eb2. ring_simplify.
    apply compose_lt with (a * b).
     now apply pos_mult_compat.
    ring.
  Qed.

  Global Instance: StrictSemiRingOrder SRpair_lt.
  Proof. apply from_strict_ring_order; apply _. Qed.
End with_strict_semiring_order.

Section with_full_pseudo_semiring_order.
  Context `{!FullPseudoSemiRingOrder SRle SRlt}.

  Instance: StrongSetoid SR := pseudo_order_setoid.

  Instance: StrongSetoid (SRpair SR).
  Proof.
    split.
       intros [??] E. now eapply (irreflexivity (≶)); eauto.
      intros [??] [??] E. unfold apart, SRpair_apart. now symmetry.
     intros [xp xn] [yp yn] E [zp zn]. unfold apart, SRpair_apart in *. simpl in *.
     apply (strong_left_cancellation (+) zn) in E.
     edestruct (cotransitive E).
      left. apply (strong_extensionality (+ yn)).
      setoid_replace (xp + zn + yn) with (zn + (xp + yn)) by ring. eassumption.
     right. apply (strong_extensionality (+ xn)).
     setoid_replace (zp + yn + xn) with (zp + xn + yn) by ring.
     setoid_replace (yp + zn + xn) with (zn + (yp + xn)) by ring.
     eassumption.
    intros [??] [??]. now rapply tight_apart.
  Qed.

  Instance: FullPseudoOrder SRpair_le SRpair_lt.
  Proof.
    split.
     split; try apply _.
       intros [??] [??]. unfold_lt. now apply pseudo_order_antisym.
      intros [xp xn] [yp yn] E [zp zn]. unfold lt, SRpair_lt in *. simpl in *.
      apply (strictly_order_preserving (zn +)) in E.
      edestruct (cotransitive E).
       left. apply (strictly_order_reflecting (+ yn)).
       setoid_replace (xp + zn + yn) with (zn + (xp + yn)) by ring. eassumption.
      right. apply (strictly_order_reflecting (+ xn)).
      setoid_replace (zp + yn + xn) with (zp + xn + yn) by ring.
      setoid_replace (yp + zn + xn) with (zn + (yp + xn)) by ring.
      eassumption.
     intros [??] [??]. now rapply apart_iff_total_lt.
    intros [??] [??]. now rapply le_iff_not_lt_flip.
  Qed.

  Instance: ∀ z : SRpair SR, StrongSetoid_Morphism (z *.).
  Proof.
    intros [zp zn]. split; try apply _. intros [xp xn] [yp yn] E1.
    unfold apart, SRpair_apart in *. simpl in *.
    destruct (strong_binary_extensionality (+)
       (zp * (xp + yn)) (zn * (yp + xn)) (zp * (yp + xn)) (zn * (xp + yn))).
      eapply strong_setoids.apart_proper; eauto; ring.
     now apply (strong_extensionality (zp *.)).
    symmetry. now apply (strong_extensionality (zn *.)).
  Qed.

  Global Instance: FullPseudoSemiRingOrder SRpair_le SRpair_lt.
  Proof.
    apply from_full_pseudo_ring_order; try apply _.
    now apply strong_setoids.strong_binary_setoid_morphism_commutative.
  Qed.
End with_full_pseudo_semiring_order.

Global Instance SRpair_dec `{∀ x y : SR, Decision (x = y)} : ∀ x y : SRpair SR, Decision (x = y)
  := λ x y, decide_rel (=) (pos x + neg y) (pos y + neg x).

Global Program Instance SRpair_le_dec `{Le SR} `{∀ x y: SR, Decision (x ≤ y)} : ∀ x y : SRpair SR, Decision (x ≤ y) := λ x y,
  match decide_rel (≤) (pos x + neg y) (pos y + neg x) with
  | left E => left _
  | right E => right _
  end.

End semiring_pairs.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Opaque SRpair_equiv.
#[global]
Typeclasses Opaque SRpair_le.


Require Import FreeProving.Free.
Require Import FreeProving.Effects.
Require Import FreeProving.List.

Set Implicit Arguments.

Section append_assoc.

  Import Tactics.

  Variable A : Type.

  Section ZeroContainer.

    Import Zero.

    Lemma append'_assoc__Id : forall (xs : List C__Zero A) (fys fzs : Free C__Zero (List C__Zero A)),
        append' xs (append fys fzs) = append (append' xs fys) fzs.
    Proof.
      (*Let [xs], [fys], [fzs] be arbitrary. *)
      intros xs fys fzs.

      (*Perform induction over the [List] structure [xs]. *)
      induction xs using List_Ind.

      - (*Base case: [xs = nil] *)
        reflexivity.

      - (*Inductive case: [xs = cons fx fxs] with induction hypothesis [H]
          Perform induction over the [Free] structure [fxs]. *)
        induction fxs using Free_Ind.

        + (*Base case: [fxs = pure x]
            Simplify and use induction hypothesis [IH]. *)
          simpl. simplify H as IH. rewrite IH. reflexivity.

        + (*Inductive case: [fxs = impure (ext s pf)] with [s] of type [S__Zero] *)
          destruct s.
    Qed.

    Lemma append_assoc__Id : forall (fxs fys fzs : Free C__Zero (List C__Zero A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      (*Let [fxs], [fys], [fzs] be arbitrary. *)
      intros fxs fys fzs.

      (*Perform induction over the [Free] structure of [fxs]. *)
      induction fxs using Free_Ind.

      - (*Base case: [fxs = pure x]
          Simplify and use auxiliary lemma. *)
        simpl. apply append'_assoc__Id.

      - (*Inductive case: [fxs = impure (ext s pf)] with [s] of type [S__Zero] *)
        destruct s.
    Qed.

    (* This proof does not use an auxiliary lemma *)
    Lemma append_assoc__Id' : forall (fxs fys fzs : Free C__Zero (List C__Zero A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs using Free_Ind.
      - simpl. induction x using List_Ind.
        + reflexivity.
        + simpl. induction fxs using Free_Ind.
          * simpl. inversion H as [Heq IH|]; clear H; subst. rewrite IH. reflexivity.
          * destruct s.
      - destruct s.
    Qed.

    (* This proof uses a more elaborate induction principle to prevent redundancies *)
    Lemma append_assoc__Id_ : forall (fxs fys fzs : Free C__Zero (List C__Zero A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs as [ | fx' fxs' IHfxs' | xs IHxs | s pf ] using FreeList_ind
        with (P := fun xs => append' xs (append fys fzs) = append (append' xs fys) fzs);
        simpl.
      - reflexivity.
      - apply f_equal, IHfxs'.
      - apply IHxs.
      - destruct s.
    Qed.

  End ZeroContainer.

  Section OneContainer.

    Import One.

    Lemma append'_assoc__Maybe : forall (xs : List C__One A) (fys fzs : Free C__One (List C__One A)),
        append' xs (append fys fzs) = append (append' xs fys) fzs.
    Proof.
      intros xs fys fzs.
      induction xs using List_Ind.
      - reflexivity.
      - induction fxs using Free_Ind.
        + simpl. simplify H as IH. rewrite IH. reflexivity.
        + (*Inductive case: [fxs = impure (ext s pf)]
            Simplify, drop [Cons], [impure], and [ext s] on both sides. *)
        simpl. do 3 apply f_equal.

        (*Use functional extensionality and case distinction over [p : P__One s] *)
        extensionality p. destruct p.
    Qed.

    Lemma append_assoc__Maybe : forall (fxs fys fzs : Free C__One (List C__One A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs using Free_Ind.
      - simpl. apply append'_assoc__Maybe.
      - (*Inductive case: [fxs = impure (ext s pf)]
          Simplify, drop [impure], and [ext s] on both sides. *)
        simpl. do 2 apply f_equal.

        (*Use functional extensionality and case distinction over [p : P__One s]. *)
        extensionality p. destruct p.
    Qed.

    (* This proof does not use an auxiliary lemma *)
    Lemma append_assoc__Maybe' : forall (fxs fys fzs : Free C__One (List C__One A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs using Free_Ind.
      - simpl. induction x using List_Ind.
        + reflexivity.
        + simpl. induction fxs using Free_Ind.
          * simpl. simplify H as IH. rewrite IH. reflexivity.
          * simpl in *. do 3 f_equal. extensionality p. dependent destruction H. destruct p.
      - simpl. do 3 f_equal. extensionality p. destruct p.
    Qed.

    (* This proof uses a more elaborate induction principle to prevent redundancies *)
    Lemma append_assoc__Maybe_ : forall (fxs fys fzs : Free C__One (List C__One A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs as [ | fx' fxs' IHfxs' | xs IHxs | s pf ] using FreeList_ind
        with (P := fun xs => append' xs (append fys fzs) = append (append' xs fys) fzs);
        simpl.
      - reflexivity.
      - apply f_equal, IHfxs'.
      - apply IHxs.
      - do 2 apply f_equal; extensionality p; destruct p.
    Qed.

  End OneContainer.

  Section Generic.

    Variable F : Type -> Type.
    Variable C__F : Container F.

    Lemma append'_assoc : forall (xs : List C__F A) (fys fzs : Free C__F (List C__F A)),
        append' xs (append fys fzs) = append (append' xs fys) fzs.
    Proof.
      intros xs fys fzs.
      induction xs using List_Ind.
      - reflexivity.
      - induction fxs using Free_Ind.
        + simpl. simplify H as IH. rewrite IH. reflexivity.
        + (*Inductive case: [fxs = impure (ext s pf)] with induction hypothesis [H] *)
          simpl. do 3 apply f_equal. extensionality p.
          simplify H as IH. apply IH.
    Qed.

    Lemma append_assoc : forall (fxs fys fzs : Free C__F (List C__F A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs as [ | s pf IH ] using Free_Ind.
      - simpl. apply append'_assoc.
      - (*Inductive case: [fxs = impure (ext s pf)] with induction hypothesis [IH] *)
        simpl. do 2 apply f_equal. extensionality p.
        apply IH.
    Qed.

    (* This proof does not use an auxiliary lemma *)
    Lemma append_assoc__' : forall (fxs fys fzs : Free C__F (List C__F A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs using Free_Ind.
      - simpl. induction x using List_Ind.
        + reflexivity.
        + simpl. induction fxs using Free_Ind.
          * simpl. simplify H as IH. rewrite IH. reflexivity.
          * simpl in *. do 3 f_equal. extensionality p. simplify H as IH. apply IH.
      - simpl. do 3 f_equal. extensionality p. apply H.
    Qed.

    (* This proof uses a more elaborate induction principle to prevent redundancies *)
    Lemma append_assoc_ : forall (fxs fys fzs : Free C__F (List C__F A)),
        append fxs (append fys fzs) = append (append fxs fys) fzs.
    Proof.
      intros fxs fys fzs.
      induction fxs as [ | fx' fxs' IHfxs' | xs IHxs | s pf ] using FreeList_ind
        with (P := fun xs => append' xs (append fys fzs) = append (append' xs fys) fzs).
      - reflexivity.
      - simpl. apply f_equal. apply IHfxs'.
      - simpl. apply IHxs.
      - simpl. do 2 apply f_equal. extensionality p. apply H.
    Qed.

  End Generic.

End append_assoc.


Require Export FunctionalExtensionality.
Require Export PropExtensionality.
Require Export PeanoNat.
Require Export Classical.

Require Coq.Lists.List.
Require Coq.Vectors.Vector.

(* Type classifiers *)

Class finite (T: Type) := mkfinite
{ listing: list T
; listing_full: forall (t: T), List.In t listing }.

Class denumerable (T: Type) := mkdenumerable
{ enumerate: nat -> T
; enumerate_inject: forall (n m: nat), enumerate n = enumerate m -> n = m
; enumerate_surject: forall (t: T), exists (n: nat), enumerate n = t }.

Inductive countable (T: Type) :=
| is_finite: finite T -> countable T
| is_infinite: denumerable T -> countable T.

Class discrete (T: Type) := mkdiscrete
{ eq_dec (x y: T): {x = y} + {x <> y} }.

Instance nat_discrete: discrete nat := {| eq_dec := Nat.eq_dec |}.

(* Sets and relations *)

Definition Union {D: Type} (R1 R2: D -> Prop): D -> Prop :=
fun x => R1 x \/ R2 x.

Definition Intersect {D: Type} (R1 R2: D -> Prop): D -> Prop :=
fun x => R1 x /\ R2 x.

Definition Empty (D: Type): D -> Prop :=
fun x => False.

Definition Full (D: Type): D -> Prop :=
fun x => True.

Definition Subtract {D: Type} `{discrete D} (R: D -> Prop) (y: D): D -> Prop :=
fun x => if eq_dec x y then False else R x.

Definition Disjoint {D: Type} (R1 R2: D -> Prop): Prop :=
Intersect R1 R2 = Empty D.

Definition DisjointUnion {D: Type} (R R1 R2: D -> Prop): Prop :=
R = Union R1 R2 /\ Disjoint R1 R2.

Lemma DisjointUnion_spec {D: Type} (R R1 R2: D -> Prop):
  DisjointUnion R R1 R2 <-> forall x, (R x <-> R1 x \/ R2 x) /\ ~(R1 x /\ R2 x).
split; intro.
- unfold DisjointUnion in H; destruct H.
  unfold Union in H.
  unfold Disjoint in H0.
  unfold Empty in H0.
  unfold Intersect in H0.
  intros. split.
  + rewrite H. apply iff_refl.
  + remember (fun x : D => R1 x /\ R2 x) as f.
    remember (fun _ : D => False) as g.
    assert (f x = g x).
    rewrite H0; reflexivity.
    rewrite Heqf in H1.
    rewrite Heqg in H1.
    rewrite H1.
    intro; auto.
- unfold DisjointUnion. split.
  + unfold Union.
    apply functional_extensionality; intro x.
    specialize H with x; destruct H.
    apply propositional_extensionality; split; intro.
    rewrite H in H1; auto.
    rewrite H; auto.
  + unfold Disjoint.
    unfold Intersect.
    unfold Empty.
    apply functional_extensionality; intro x.
    specialize H with x; destruct H.
    apply propositional_extensionality; split; intro.
    auto. exfalso; auto.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Lt Coq.Arith.Plus.

Set Implicit Arguments.
Set Strict Implicit.

Section parametric.
  Variable T : Type.

  Lemma nth_error_app_L : forall (A B : list T) n,
    n < length A ->
    nth_error (A ++ B) n = nth_error A n.
  Proof.
    induction A; destruct n; simpl; intros; auto.
    { inversion H. }
    { inversion H. }
    { eapply IHA. apply Lt.lt_S_n; assumption. }
  Qed.

  Lemma nth_error_app_R : forall (A B : list T) n,
    length A <= n ->
    nth_error (A ++ B) n = nth_error B (n - length A).
  Proof.
    induction A; destruct n; simpl; intros; auto.
    + inversion H.
    + apply IHA. apply Le.le_S_n; assumption.
  Qed.

  Lemma nth_error_weaken : forall ls' (ls : list T) n v,
    nth_error ls n = Some v ->
    nth_error (ls ++ ls') n = Some v.
  Proof.
    clear. induction ls; destruct n; simpl; intros; unfold value, error in *; try congruence; auto.
  Qed.

  Lemma nth_error_nil : forall n,
    nth_error nil n = @None T.
  Proof.
    destruct n; reflexivity.
  Qed.

  Lemma nth_error_past_end : forall (ls : list T) n,
    length ls <= n ->
    nth_error ls n = None.
  Proof.
    clear. induction ls; destruct n; simpl; intros; auto.
    + inversion H.
    + apply IHls. apply Le.le_S_n; assumption.
  Qed.

  Lemma nth_error_length : forall (ls ls' : list T) n,
    nth_error (ls ++ ls') (n + length ls) = nth_error ls' n.
  Proof.
    induction ls; simpl; intros.
    rewrite Plus.plus_0_r. auto.
    rewrite <- Plus.plus_Snm_nSm.
    simpl. eapply IHls.
  Qed.

  Theorem nth_error_length_ge : forall T (ls : list T) n,
    nth_error ls n = None -> length ls <= n.
  Proof.
    induction ls; destruct n; simpl in *; auto; simpl in *.
    + intro. apply Le.le_0_n.
    + inversion 1.
    + intros. eapply Le.le_n_S. auto.
  Qed.

  Lemma nth_error_length_lt : forall {T} (ls : list T) n val,
    nth_error ls n = Some val -> n < length ls.
  Proof.
    induction ls; destruct n; simpl; intros; auto.
    + inversion H.
    + inversion H.
    + apply Lt.lt_0_Sn.
    + apply Lt.lt_n_S. eauto.
  Qed.

  Theorem nth_error_map : forall U (f : T -> U) ls n,
    nth_error (map f ls) n = match nth_error ls n with
                               | None => None
                               | Some x => Some (f x)
                             end.
  Proof.
    induction ls; destruct n; simpl; auto.
  Qed.

End parametric.