(* Lemma 2.2 of the proof of the sensitivity conjecture *)

(* Lemma 2.2. We define a sequence of symmetric square matrices
   iteratively as follows

     A1 = [ 0 1 ]
          [ 1 0 ],
     An = [ A_{n-1} I        ]
          [ I       -A_{n-1} ]

   Then An is a 2^n x 2^n matrix whose eigenvalues are √n of multiplitiy
   2^{n-1} and -√n of multiplicity 2^{n-1}.
 *)

Set Nested Proofs Allowed.
Set Implicit Arguments.

Require Import Utf8 Arith.
Import List List.ListNotations.

Require Import Misc RingLike MyVector Matrix.
Require Import IterAdd.
Import matrix_Notations.

Section a.

Context {T : Type}.
Context {ro : ring_like_op T}.
Context {rp : ring_like_prop T}.

Fixpoint map3 {A} f (la lb : list A) : list A :=
  match la with
  | [] => lb
  | a :: la' =>
      match lb with
      | [] => la
      | b :: lb' => f a b :: map3 f la' lb'
      end
  end.

Theorem map3_nil_r : ∀ A f (la : list A), map3 f la [] = la.
Proof.
intros.
now induction la.
Qed.

(* *)

Definition fold_app_in_list (lll : list (list (list T))) :=
  iter_list lll (map3 (app (A:=T))) [].

Definition flatten_list_list llll := flat_map fold_app_in_list llll.

Definition mat_of_mat_list_list (mll : list (list (matrix T))) : matrix T :=
  mk_mat (flatten_list_list (map (map (@mat_list_list T)) mll)).

(* sequence "An" *)

Fixpoint mA (n : nat) : matrix T :=
  match n with
  | 0 => mZ 1 1
  | S n' =>
      mat_of_mat_list_list
        [[mA n'; mI (2 ^ n')];
         [mI (2 ^ n'); (- mA n')%M]]
  end.

Theorem length_app_in_list : ∀ la lb,
  length (map3 (app (A := T)) la lb) = max (length la) (length lb).
Proof.
intros.
revert lb.
induction la as [| a]; intros; [ easy | cbn ].
destruct lb as [| b]; [ easy | cbn ].
now rewrite IHla.
Qed.

Theorem length_hd_app_in_list : ∀ la lb : list (list T),
  length (hd [] (map3 (app (A := T)) la lb)) =
  length (hd [] la) + length (hd [] lb).
Proof.
intros.
destruct la as [| a]; [ easy | cbn ].
destruct lb as [| b]; [ easy | cbn ].
apply app_length.
Qed.

Theorem mA_nrows : ∀ n, mat_nrows (mA n) = 2 ^ n.
Proof.
intros.
induction n; [ easy | ].
cbn - [ "^" ].
rewrite app_nil_r.
rewrite app_length.
unfold fold_app_in_list, iter_list; cbn.
do 2 rewrite length_app_in_list.
do 2 rewrite map_length.
rewrite seq_length.
do 2 rewrite Nat.max_comm.
rewrite fold_mat_nrows, IHn.
rewrite Nat.max_id; cbn.
now rewrite Nat.add_0_r.
Qed.

Theorem mA_ncols : ∀ n, mat_ncols (mA n) = 2 ^ n.
Proof.
intros.
induction n; [ easy | ].
cbn - [ "^" ].
unfold mat_ncols; cbn - [ "^" ].
rewrite List_app_hd1. 2: {
  unfold fold_app_in_list, iter_list; cbn.
  rewrite length_app_in_list.
  rewrite List_map_seq_length.
  rewrite fold_mat_nrows.
  rewrite mA_nrows, Nat.max_id.
  apply Nat.neq_0_lt_0.
  now apply Nat.pow_nonzero.
}
unfold mat_ncols in IHn.
unfold fold_app_in_list, iter_list; cbn.
rewrite length_hd_app_in_list, IHn.
rewrite (List_map_hd 0). 2: {
  rewrite seq_length.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
}
rewrite List_map_seq_length; cbn.
now rewrite Nat.add_0_r.
Qed.

Theorem nth_map3_app : ∀ i lla llb d,
  i < length lla
  → i < length llb
  → nth i (map3 (app (A:=T)) lla llb) d = nth i lla d ++ nth i llb d.
Proof.
intros * Ha Hb.
revert i llb Ha Hb.
induction lla as [| la]; intros; [ easy | cbn ].
destruct llb as [| lb]; [ easy | cbn ].
destruct i; [ easy | ].
cbn in Ha, Hb.
apply Nat.succ_lt_mono in Ha.
apply Nat.succ_lt_mono in Hb.
now apply IHlla.
Qed.

Theorem in_map3_app : ∀ la lla llb,
  la ∈ map3 (app (A:=T)) lla llb
  → ∃ i,
    i < max (length lla) (length llb) ∧ la = nth i lla [] ++ nth i llb [].
Proof.
intros * Hla.
rename la into lc.
revert llb Hla.
induction lla as [| la]; intros; cbn. {
  cbn in Hla.
  induction llb as [| lb]; [ easy | ].
  destruct Hla as [Hla| Hla]. {
    subst lc.
    exists 0.
    split; [ | easy ].
    cbn; flia.
  } {
    specialize (IHllb Hla).
    destruct IHllb as (i & Hil & Hc).
    exists (S i).
    subst lc; cbn.
    split; [ now apply -> Nat.succ_lt_mono | ].
    now destruct i.
  }
}
destruct llb as [| lb]. {
  cbn in Hla |-*.
  destruct Hla as [Hla| Hla]. {
    subst lc; cbn.
    exists 0.
    split; [ easy | ].
    symmetry; apply app_nil_r.
  } {
    cbn.
    apply In_nth with (d := []) in Hla.
    destruct Hla as (n & Hnl & Hn).
    subst lc.
    exists (S n).
    split; [ now apply -> Nat.succ_lt_mono | ].
    symmetry; apply app_nil_r.
  }
}
cbn in Hla.
destruct Hla as [Hla| Hla]. {
  exists 0.
  subst lc; cbn.
  split; [ easy | easy ].
}
specialize (IHlla _ Hla).
destruct IHlla as (n & Hn & Hc).
exists (S n); cbn.
split; [ now apply -> Nat.succ_lt_mono | easy ].
Qed.

Theorem mA_is_correct : ∀ n, is_correct_matrix (mA n) = true.
Proof.
intros.
induction n. {
  now apply mZ_is_correct_matrix.
}
apply is_scm_mat_iff.
split; [ now rewrite mA_nrows, mA_ncols | ].
intros la Hla.
rewrite mA_ncols.
cbn in Hla.
rewrite app_nil_r in Hla.
apply in_app_or in Hla.
destruct Hla as [Hla| Hla]. {
  apply in_map3_app in Hla.
  destruct Hla as (i & Him & Hla).
  unfold map3 in Him.
  rewrite fold_mat_nrows, mA_nrows in Him.
  rewrite List_map_seq_length in Him.
  rewrite Nat.max_id in Him.
  subst la.
  rewrite app_length.
  unfold map3.
  rewrite fold_corr_mat_ncols; [ | easy | now rewrite mA_nrows ].
  rewrite mA_ncols.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  rewrite List_map_seq_length.
  now cbn; rewrite Nat.add_0_r.
} {
  apply in_map3_app in Hla.
  destruct Hla as (i & Him & Hla).
  unfold map3 in Him.
  rewrite List_map_seq_length in Him.
  rewrite map_length in Him.
  rewrite fold_mat_nrows, mA_nrows, Nat.max_id in Him.
  subst la; cbn.
  rewrite app_length.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  rewrite List_map_seq_length.
  f_equal; rewrite Nat.add_0_r.
  rewrite (List_map_nth' []). 2: {
    now rewrite fold_mat_nrows, mA_nrows.
  }
  rewrite map_length.
  rewrite fold_corr_mat_ncols; cycle 2. {
    now rewrite mA_nrows.
  } {
    apply mA_ncols.
  }
  easy.
}
Qed.

Theorem mA_is_square_matrix : ∀ n, is_square_matrix (mA n) = true.
Proof.
intros.
apply is_scm_mat_iff.
rewrite mA_nrows, mA_ncols.
split; [ easy | ].
intros la Hla.
revert la Hla.
induction n; intros. {
  cbn in Hla |-*.
  destruct Hla as [H| H]; [ now subst la | easy ].
}
cbn in Hla.
rewrite app_nil_r in Hla.
apply in_app_iff in Hla.
destruct Hla as [Hla| Hla]. {
  apply in_map3_app in Hla.
  destruct Hla as (i & Him & Hla); subst la.
  unfold map3 in Him.
  rewrite fold_mat_nrows, mA_nrows in Him.
  rewrite List_map_seq_length, Nat.max_id in Him.
  rewrite app_length; cbn.
  rewrite fold_corr_mat_ncols; cycle 1. {
    apply mA_is_correct.
  } {
    now rewrite mA_nrows.
  }
  rewrite mA_ncols.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  rewrite List_map_seq_length; cbn.
  now rewrite Nat.add_0_r.
} {
  apply in_map3_app in Hla.
  destruct Hla as (i & Him & Hla); subst la.
  unfold map3 in Him.
  rewrite List_map_seq_length in Him.
  rewrite map_length in Him.
  rewrite fold_mat_nrows, mA_nrows, Nat.max_id in Him.
  rewrite app_length; cbn.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  rewrite (List_map_nth' []); [ | now rewrite fold_mat_nrows, mA_nrows ].
  do 2 rewrite map_length.
  rewrite seq_length.
  rewrite fold_corr_mat_ncols; cycle 1. {
    apply mA_is_correct.
  } {
    now rewrite mA_nrows.
  }
  rewrite mA_ncols; cbn.
  now rewrite Nat.add_0_r.
}
Qed.

Theorem le_pow_succ_sub_1_lt : ∀ n j, j ≤ 2 ^ S n - 1 → j - 2 ^ n < 2 ^ n.
Proof.
intros * Hj.
apply (Nat.add_lt_mono_r _ _ (2 ^ n)).
destruct (le_dec (2 ^ n) j) as [H1| H1]. {
  rewrite Nat.sub_add; [ | easy ].
  cbn in Hj; rewrite Nat.add_0_r in Hj.
  apply (le_lt_trans _ (2 ^ n + 2 ^ n - 1)); [ easy | ].
  apply Nat.sub_lt; [ | easy ].
  apply Nat.neq_0_lt_0.
  intros H.
  apply Nat.eq_add_0 in H.
  destruct H as (H, _); revert H.
  now apply Nat.pow_nonzero.
} {
  apply Nat.nle_gt in H1.
  rewrite (proj2 (Nat.sub_0_le j (2 ^ n))); [ | flia H1 ].
  apply Nat.lt_add_pos_r.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
}
Qed.

Theorem le_pow_sub_1_lt : ∀ n j, j ≤ 2 ^ n - 1 → j < 2 ^ n.
Proof.
intros n j Hj.
apply (le_lt_trans _ (2 ^ n - 1)); [ easy | ].
apply Nat.sub_lt; [ | easy ].
apply Nat.neq_0_lt_0.
now apply Nat.pow_nonzero.
Qed.

(* "We prove by induction that A_n^2 = nI" *)

Theorem lemma_2_A_n_2_eq_n_I :
  rngl_has_opp = true →
  ∀ n, (mA n * mA n)%M = (rngl_of_nat n × mI (2 ^ n))%M.
Proof.
intros Hop *.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before Hop.
unfold "*"%M, "×"%M.
cbn; f_equal.
rewrite mA_nrows.
rewrite map_map.
rewrite <- seq_shift with (len := 2 ^ n), map_map.
apply map_ext_in.
intros i Hi.
rewrite mA_ncols.
rewrite map_map.
rewrite <- seq_shift, map_map.
apply map_ext_in.
intros k Hk.
move k before i.
unfold mat_mul_el.
rewrite mA_ncols.
apply in_seq in Hi, Hk.
destruct Hi as (_, Hi).
destruct Hk as (_, Hk).
rewrite Nat.add_0_l in Hi, Hk.
revert i k Hi Hk.
induction n; intros. {
  apply Nat.lt_1_r in Hi, Hk; subst i k; cbn.
  rewrite rngl_summation_only_one.
  rewrite Nat.sub_diag.
  rewrite rngl_mul_0_l; [ | easy ].
  now rewrite rngl_mul_0_l.
}
rewrite (rngl_summation_split (2 ^ n)). 2: {
  split; [ flia | ].
  apply -> Nat.succ_le_mono.
  apply Nat.pow_le_mono_r; [ easy | flia ].
}
cbn - [ Nat.pow ].
rewrite rngl_add_comm.
rewrite app_nil_r.
erewrite rngl_summation_eq_compat. 2: {
  intros j Hj.
  assert (Hj' : 2 ^ n ≤ j - 1 ≤ 2 ^ S n - 1) by flia Hj.
  do 2 rewrite Nat.sub_0_r.
  unfold fold_app_in_list, iter_list; cbn.
  rewrite app_nth2 with (n := j - 1). 2: {
    rewrite length_app_in_list.
    rewrite List_map_seq_length.
    now rewrite fold_mat_nrows, mA_nrows, Nat.max_id.
  }
  rewrite length_app_in_list.
  rewrite fold_mat_nrows, mA_nrows.
  rewrite List_map_seq_length, Nat.max_id.
  rewrite nth_map3_app; cycle 1. {
    now rewrite List_map_seq_length; apply le_pow_succ_sub_1_lt.
  } {
    rewrite map_length, fold_mat_nrows, mA_nrows.
    now apply le_pow_succ_sub_1_lt.
  }
  rewrite (List_map_nth' 0). 2: {
    rewrite seq_length.
    now apply le_pow_succ_sub_1_lt.
  }
  rewrite (List_map_nth' []). 2: {
    rewrite fold_mat_nrows, mA_nrows.
    now apply le_pow_succ_sub_1_lt.
  }
  rewrite seq_nth; [ cbn | now apply le_pow_succ_sub_1_lt ].
  easy.
}
cbn - [ "^" ].
destruct (lt_dec i (2 ^ n)) as [Hin| Hin]. {
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    assert (Hj' : 2 ^ n ≤ j - 1 ≤ 2 ^ S n - 1) by flia Hj.
    rewrite app_nth1. 2: {
      rewrite length_app_in_list.
      rewrite List_map_seq_length.
      now rewrite fold_mat_nrows, mA_nrows, Nat.max_id.
    }
    rewrite nth_map3_app; cycle 1. {
      now rewrite fold_mat_nrows, mA_nrows.
    } {
      now rewrite List_map_seq_length.
    }
    rewrite app_nth2. 2: {
      rewrite fold_corr_mat_ncols; cycle 2. {
        now rewrite mA_nrows.
      } {
        now rewrite mA_ncols.
      }
      apply mA_is_correct.
    }
    rewrite fold_corr_mat_ncols; cycle 1. {
      apply mA_is_correct.
    } {
      now rewrite mA_nrows.
    }
    rewrite mA_ncols.
    rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
    rewrite seq_nth; [ cbn | easy ].
    rewrite (List_map_nth' 0). 2: {
      now rewrite seq_length; apply le_pow_succ_sub_1_lt.
    }
    rewrite seq_nth; [ cbn | now apply le_pow_succ_sub_1_lt ].
    easy.
  }
  cbn - [ "^" ].
  rewrite rngl_add_comm.
  do 2 rewrite Nat.sub_0_r.
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    assert (Hj' : j - 1 ≤ 2 ^ n - 1) by flia Hj.
    unfold fold_app_in_list, iter_list; cbn.
    rewrite app_nth1 with (n := j - 1). 2: {
      rewrite length_app_in_list.
      rewrite List_map_seq_length.
      rewrite fold_mat_nrows, mA_nrows, Nat.max_id.
      now apply le_pow_sub_1_lt.
    }
    rewrite app_nth1. 2: {
      rewrite length_app_in_list.
      rewrite List_map_seq_length.
      now rewrite fold_mat_nrows, mA_nrows, Nat.max_id.
    }
    rewrite nth_map3_app; cycle 1. {
      now rewrite fold_mat_nrows, mA_nrows.
    } {
      now rewrite List_map_seq_length.
    }
    rewrite nth_map3_app; cycle 1. {
      rewrite fold_mat_nrows, mA_nrows.
      now apply le_pow_sub_1_lt.
    } {
      rewrite List_map_seq_length.
      now apply le_pow_sub_1_lt.
    }
    rewrite app_nth1. 2: {
      rewrite fold_corr_mat_ncols; cycle 2. {
        now rewrite mA_nrows.
      } {
        rewrite mA_ncols.
        now apply le_pow_sub_1_lt.
      }
      apply mA_is_correct.
    }
    rewrite fold_mat_el.
    easy.
  }
  rewrite rngl_add_comm.
  destruct (lt_dec k (2 ^ n)) as [Hkn| Hkn]. {
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite app_nth1. 2: {
        now rewrite List_map_seq_length.
      }
      rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
      rewrite seq_nth; [ cbn | easy ].
      easy.
    }
    rewrite rngl_add_comm.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      assert (Hj' : j - 1 ≤ 2 ^ n - 1) by flia Hj.
      rewrite <- Nat.sub_succ_l; [ | easy ].
      rewrite Nat_sub_succ_1.
      rewrite app_nth1. 2: {
        rewrite fold_corr_mat_ncols; cycle 2. {
          rewrite mA_nrows.
          now apply le_pow_sub_1_lt.
        } {
          now rewrite mA_ncols.
        }
        apply mA_is_correct.
      }
      rewrite fold_mat_el.
      rewrite <- Nat.sub_succ_l; [ | easy ].
      rewrite Nat_sub_succ_1.
      easy.
    }
    rewrite rngl_add_comm.
    rewrite IHn; [ | easy | easy ].
    rewrite rngl_mul_add_distr_r, rngl_mul_1_l.
    f_equal.
    rewrite (rngl_summation_shift (2 ^ n)). 2: {
      split; [ flia | ].
      cbn; rewrite Nat.add_0_r.
      apply Nat.add_le_mono_l.
      now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
    }
    rewrite Nat.add_comm, Nat.add_sub.
    cbn; rewrite Nat.add_0_r.
    rewrite Nat.add_sub.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite Nat_sub_sub_swap.
      now rewrite Nat.add_comm, Nat.add_sub.
    }
    cbn.
    destruct (lt_eq_lt_dec i k) as [[Hik| Hik]| Hik]. {
      rewrite δ_ndiag; [ | flia Hik ].
      apply all_0_rngl_summation_0.
      intros j Hj.
      unfold δ.
      do 2 rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec i (j - 1)) as [Hij| Hij]. {
        destruct (Nat.eq_dec (j - 1) k) as [Hjk| Hjk]. {
          rewrite Hij, Hjk in Hik; flia Hik.
        }
        now apply rngl_mul_0_r.
      } {
        now apply rngl_mul_0_l.
      }
    } {
      subst k.
      rewrite δ_diag.
      rewrite (rngl_summation_split3 (S i)); [ | split; flia Hin ].
      rewrite all_0_rngl_summation_0. 2: {
        intros j Hj.
        rewrite δ_ndiag; [ | flia Hj ].
        now apply rngl_mul_0_l.
      }
      rewrite rngl_add_0_l.
      rewrite Nat_sub_succ_1.
      rewrite δ_diag, rngl_mul_1_l.
      rewrite all_0_rngl_summation_0. 2: {
        intros j Hj.
        rewrite δ_ndiag; [ | flia Hj ].
        now apply rngl_mul_0_l.
      }
      apply rngl_add_0_r.
    } {
      rewrite δ_ndiag; [ | flia Hik ].
      apply all_0_rngl_summation_0.
      intros j Hj.
      unfold δ.
      do 2 rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec i (j - 1)) as [Hij| Hij]. {
        destruct (Nat.eq_dec (j - 1) k) as [Hjk| Hjk]. {
          rewrite Hij, Hjk in Hik; flia Hik.
        }
        now apply rngl_mul_0_r.
      } {
        now apply rngl_mul_0_l.
      }
    }
  } {
    apply Nat.nlt_ge in Hkn.
    rewrite δ_ndiag; [ | flia Hin Hkn ].
    rewrite rngl_mul_0_r; [ | easy ].
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      assert (Hj' : j - 1 ≤ 2 ^ S n - 1) by flia Hj.
      rewrite app_nth2. 2: {
        now rewrite List_map_seq_length.
      }
      rewrite List_map_seq_length.
      rewrite (List_map_nth' 0%L). 2: {
        rewrite fold_corr_mat_ncols; cycle 1. {
          apply mA_is_correct.
        } {
          rewrite mA_nrows.
          now apply le_pow_succ_sub_1_lt.
        }
        rewrite mA_ncols.
        apply Nat.add_lt_mono_r with (p := 2 ^ n).
        rewrite Nat.sub_add; [ | easy ].
        now cbn in Hk; rewrite Nat.add_0_r in Hk.
      }
      rewrite fold_mat_el.
      now rewrite rngl_mul_opp_r.
    }
    rewrite (rngl_summation_shift (2 ^ n + 1)). 2: {
      split; [ easy | ].
      cbn; rewrite Nat.add_0_r.
      apply Nat.add_le_mono_l.
      now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
    }
    rewrite Nat.sub_diag.
    rewrite <- rngl_opp_summation; [ | easy ].
    cbn; rewrite Nat.add_0_r.
    rewrite Nat.sub_add_distr, Nat.add_sub.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite (Nat.add_comm _ j), Nat.add_assoc.
      now do 2 rewrite Nat.add_sub.
    }
    rewrite rngl_add_comm.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      assert (Hj' : j - 1 < 2 ^ n) by flia Hj.
      rewrite <- Nat.sub_succ_l; [ | easy ].
      rewrite Nat_sub_succ_1.
      rewrite app_nth2. 2: {
        rewrite fold_corr_mat_ncols; cycle 2. {
          now rewrite mA_nrows.
        } {
          now rewrite mA_ncols.
        }
        apply mA_is_correct.
      }
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply mA_is_correct.
      } {
        now rewrite mA_nrows.
      }
      rewrite mA_ncols.
      rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length.
        apply le_pow_succ_sub_1_lt; flia Hk.
      }
      rewrite seq_nth; [ | easy ].
      rewrite seq_nth; [ | apply le_pow_succ_sub_1_lt; flia Hk ].
      now cbn.
    }
    cbn.
    rewrite fold_rngl_sub; [ | easy ].
    rewrite (rngl_summation_split3 (k - 2 ^ n + 1)). 2: {
      split; [ flia Hk | ].
      apply (Nat.add_le_mono_r _ _ (2 ^ n)).
      rewrite <- Nat.add_assoc.
      rewrite (Nat.add_comm _ (2 ^ n)).
      rewrite Nat.add_assoc.
      rewrite Nat.sub_add; [ | easy ].
      cbn in Hk; rewrite Nat.add_0_r in Hk.
      flia Hk.
    }
    rewrite Nat.add_sub.
    rewrite δ_diag, rngl_mul_1_r.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite δ_ndiag; [ | flia Hj ].
      now apply rngl_mul_0_r.
    }
    rewrite rngl_add_0_l.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite δ_ndiag; [ | flia Hj ].
      now apply rngl_mul_0_r.
    }
    rewrite rngl_add_0_r.
    rewrite (rngl_summation_split3 i). 2: {
      split; [ easy | flia Hin ].
    }
    rewrite δ_diag, rngl_mul_1_l.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite δ_ndiag; [ | flia Hj ].
      now apply rngl_mul_0_l.
    }
    rewrite rngl_add_0_l.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite δ_ndiag; [ | flia Hj ].
      now apply rngl_mul_0_l.
    }
    rewrite rngl_add_0_r.
    rewrite Nat.add_1_r.
    now apply rngl_sub_diag.
  }
} {
  apply Nat.nlt_ge in Hin.
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    assert (Hj' : 2 ^ n ≤ j - 1) by flia Hj.
    rewrite app_nth2. 2: {
      rewrite length_app_in_list.
      rewrite List_map_seq_length.
      now rewrite fold_mat_nrows, mA_nrows, Nat.max_id.
    }
    rewrite length_app_in_list.
    rewrite List_map_seq_length.
    rewrite fold_mat_nrows, mA_nrows.
    rewrite Nat.max_id.
    rewrite nth_map3_app; cycle 1. {
      rewrite List_map_seq_length.
      apply le_pow_succ_sub_1_lt; flia Hi.
    } {
      rewrite map_length, fold_mat_nrows, mA_nrows.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite app_nth2. 2: {
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      now rewrite List_map_seq_length.
    }
    rewrite (List_map_nth' 0). 2: {
      rewrite seq_length.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite List_map_seq_length.
    rewrite (List_map_nth' []). 2: {
      rewrite fold_mat_nrows, mA_nrows.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite (List_map_nth' 0%L). 2: {
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply mA_is_correct.
      } {
        rewrite mA_nrows.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      rewrite mA_ncols; apply le_pow_succ_sub_1_lt.
      flia Hj.
    }
    now rewrite fold_mat_el.
  }
  cbn - [ "^" ].
  destruct (lt_dec k (2 ^ n)) as [Hkn| Hkn]. {
    rewrite δ_ndiag; [ | flia Hin Hkn ].
    rewrite rngl_mul_0_r; [ | easy ].
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite app_nth1. 2: {
        now rewrite List_map_seq_length.
      }
      rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
      rewrite seq_nth; [ cbn | easy ].
      rewrite rngl_mul_opp_l; [ | easy ].
      easy.
    }
    cbn - [ "^" ].
    rewrite <- rngl_opp_summation; [ | easy ].
    rewrite (rngl_summation_split3 (k + 2 ^ n + 1)). 2: {
      split; [ flia | cbn; flia Hkn ].
    }
    do 2 rewrite Nat.add_sub.
    rewrite δ_diag, rngl_mul_1_r.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite δ_ndiag; [ | flia Hj Hkn ].
      now apply rngl_mul_0_r.
    }
    rewrite rngl_add_0_l.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite δ_ndiag; [ | flia Hj Hkn ].
      now apply rngl_mul_0_r.
    }
    rewrite rngl_add_0_r.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      unfold fold_app_in_list, iter_list; cbn.
      do 2 rewrite Nat.sub_0_r.
      rewrite app_nth2. 2: {
        rewrite length_app_in_list, fold_mat_nrows, mA_nrows.
        now rewrite List_map_seq_length, Nat.max_id.
      }
      rewrite length_app_in_list, fold_mat_nrows, mA_nrows.
      rewrite List_map_seq_length, Nat.max_id.
      rewrite nth_map3_app; cycle 1. {
        rewrite List_map_seq_length.
        apply le_pow_succ_sub_1_lt; flia Hi.
      } {
        rewrite map_length, fold_mat_nrows, mA_nrows.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      rewrite (List_map_nth' []). 2: {
        rewrite fold_mat_nrows, mA_nrows.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      rewrite seq_nth; [ | apply le_pow_succ_sub_1_lt; flia Hi ].
      now cbn.
    }
    cbn.
    rewrite (rngl_summation_split3 (i - 2 ^ n + 1)). 2: {
      split; [ flia | ].
      cbn in Hi; flia Hi.
    }
    rewrite Nat.add_sub.
    rewrite app_nth1. 2: {
      rewrite List_map_seq_length.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite (List_map_nth' 0). 2: {
      rewrite seq_length.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite seq_nth. 2: {
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite δ_diag, rngl_mul_1_l.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite app_nth1. 2: {
        rewrite List_map_seq_length.
        cbn in Hi; flia Hj Hi.
      }
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length.
        cbn in Hi; flia Hj Hi.
      }
      rewrite seq_nth; [ | cbn in Hi; flia Hj Hi ].
      rewrite δ_ndiag; [ | flia Hj ].
      now apply rngl_mul_0_l.
    }
    rewrite rngl_add_0_l.
    rewrite app_nth1. 2: {
      rewrite length_app_in_list, fold_mat_nrows, mA_nrows.
      rewrite List_map_seq_length, Nat.max_id.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite nth_map3_app; cycle 1. {
      rewrite fold_mat_nrows, mA_nrows.
      apply le_pow_succ_sub_1_lt; flia Hi.
    } {
      rewrite List_map_seq_length.
      apply le_pow_succ_sub_1_lt; flia Hi.
    }
    rewrite app_nth1. 2: {
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply mA_is_correct.
      } {
        rewrite mA_nrows.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      now rewrite mA_ncols.
    }
    rewrite fold_mat_el.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite app_nth1. 2: {
        rewrite List_map_seq_length; flia Hj.
      }
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length; flia Hj.
      }
      rewrite seq_nth; [ | flia Hj ].
      rewrite δ_ndiag; [ | flia Hj ].
      now apply rngl_mul_0_l.
    }
    rewrite rngl_add_0_r.
    now apply rngl_add_opp_l.
  } {
    apply Nat.nlt_ge in Hkn.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite app_nth2. 2: {
        now rewrite List_map_seq_length.
      }
      rewrite List_map_seq_length.
      rewrite (List_map_nth' 0%L). 2: {
        rewrite fold_corr_mat_ncols; cycle 1. {
          apply mA_is_correct.
        } {
          rewrite mA_nrows; apply le_pow_succ_sub_1_lt; flia Hj.
        }
        rewrite mA_ncols.
        apply le_pow_succ_sub_1_lt; flia Hk.
      }
      rewrite rngl_mul_opp_l; [ | easy ].
      rewrite rngl_mul_opp_r; [ | easy ].
      rewrite rngl_opp_involutive; [ | easy ].
      now rewrite fold_mat_el.
    }
    cbn - [ "^" ].
    rewrite (rngl_summation_shift (2 ^ n + 1)). 2: {
      split; [ easy | flia Hi Hin ].
    }
    rewrite Nat.sub_diag; cbn.
    rewrite Nat.add_0_r.
    rewrite Nat.sub_add_distr.
    rewrite Nat.add_sub.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite (Nat.add_comm _ j).
      now rewrite Nat.add_assoc, Nat.add_sub.
    }
    cbn - [ "^" ].
    rewrite rngl_summation_rshift.
    rewrite <- Nat.sub_succ_l. 2: {
      apply Nat.neq_0_lt_0.
      now apply Nat.pow_nonzero.
    }
    rewrite Nat_sub_succ_1.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      rewrite Nat.add_sub.
      rewrite <- (Nat.sub_succ_l 1); [ | easy ].
      rewrite Nat_sub_succ_1.
      easy.
    }
    cbn.
    rewrite IHn; cycle 1. {
      apply le_pow_succ_sub_1_lt; flia Hi.
    } {
      apply le_pow_succ_sub_1_lt; flia Hk.
    }
    rewrite rngl_mul_add_distr_r, rngl_mul_1_l, rngl_add_comm.
    f_equal. 2: {
      f_equal; unfold δ; symmetry.
      rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec i k) as [Hik| Hik]. {
        now subst k; rewrite Nat.eqb_refl.
      }
      rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec _ _) as [H| H]; [ | easy ].
      flia Hik H Hin Hkn.
    }
    do 2 rewrite Nat.sub_0_r.
    erewrite rngl_summation_eq_compat. 2: {
      intros j Hj.
      unfold fold_app_in_list, iter_list; cbn.
      rewrite app_nth2. 2: {
        rewrite length_app_in_list, fold_mat_nrows, mA_nrows.
        now rewrite List_map_seq_length, Nat.max_id.
      }
      rewrite length_app_in_list, fold_mat_nrows, mA_nrows.
      rewrite List_map_seq_length, Nat.max_id.
      rewrite nth_map3_app; cycle 1. {
        rewrite List_map_seq_length.
        apply le_pow_succ_sub_1_lt; flia Hi.
      } {
        rewrite map_length, fold_mat_nrows, mA_nrows.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      rewrite seq_nth. 2: {
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      cbn.
      rewrite (List_map_nth' []). 2: {
        rewrite fold_mat_nrows, mA_nrows.
        apply le_pow_succ_sub_1_lt; flia Hi.
      }
      assert (Hj' : j - 1 < 2 ^ n) by flia Hj.
      rewrite app_nth1. 2: {
        now rewrite List_map_seq_length.
      }
      rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
      rewrite seq_nth; [ cbn | easy ].
      rewrite app_nth1. 2: {
        rewrite length_app_in_list, fold_mat_nrows, mA_nrows.
        now rewrite List_map_seq_length, Nat.max_id.
      }
      assert (Hj'' : j - 1 ≤ 2 ^ n - 1) by flia Hj.
      rewrite nth_map3_app; cycle 1. {
        now rewrite fold_mat_nrows, mA_nrows; apply le_pow_sub_1_lt.
      } {
        now rewrite List_map_seq_length; apply le_pow_sub_1_lt.
      }
      rewrite app_nth2. 2: {
        rewrite fold_corr_mat_ncols; cycle 1. {
          apply mA_is_correct.
        } {
          now rewrite mA_nrows; apply le_pow_sub_1_lt.
        }
        now rewrite mA_ncols.
      }
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply mA_is_correct.
      } {
        now rewrite mA_nrows; apply le_pow_sub_1_lt.
      }
      rewrite mA_ncols.
      rewrite (List_map_nth' 0). 2: {
        now rewrite seq_length; apply le_pow_sub_1_lt.
      }
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length; apply le_pow_succ_sub_1_lt; flia Hk.
      }
      rewrite seq_nth; [ cbn | now apply le_pow_sub_1_lt ].
      rewrite seq_nth; [ | apply le_pow_succ_sub_1_lt; flia Hk ].
      now cbn.
    }
    cbn.
    rewrite (rngl_summation_split3 (k - 2 ^ n + 1)). 2: {
      split; [ flia | cbn in Hk; flia Hk ].
    }
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite (@δ_ndiag _ _ (j - 1 - 1)); [ | flia Hj ].
      now apply rngl_mul_0_r.
    }
    rewrite rngl_add_0_l.
    rewrite all_0_rngl_summation_0. 2: {
      intros j Hj.
      rewrite (@δ_ndiag _ _ (j - 1)); [ | flia Hj ].
      now apply rngl_mul_0_r.
    }
    rewrite rngl_add_0_r.
    rewrite Nat.add_sub, δ_diag, rngl_mul_1_r.
    unfold δ; symmetry.
    rewrite if_eqb_eq_dec.
    destruct (Nat.eq_dec i k) as [Hik| Hik]. {
      now subst k; rewrite Nat.eqb_refl.
    }
    rewrite if_eqb_eq_dec.
    destruct (Nat.eq_dec _ _) as [H| H]; [ | easy ].
    flia Hik H Hin Hkn.
  }
}
Qed.

(* seems, on paper, that √(n+1) is an eignenvalue for A_{n+1}
   and a corresponding eigenvector is
      ( A_n + √(n+1) I )
      (                ) * V
      (       I        )
   for any vector V of dimension 2^(n+1).
     There is going to be a special case for n = 0.
   This way, we have to prove that this pair eigen(value,vector)
   works *)

Theorem m_o_mll_2x2_2x1 : ∀ n (M1 M2 M3 M4 M5 M6 : matrix T),
  is_square_matrix M1 = true
  → is_square_matrix M3 = true
  → is_square_matrix M5 = true
  → mat_nrows M1 = n
  → mat_nrows M2 = n
  → mat_nrows M3 = n
  → mat_nrows M4 = n
  → mat_nrows M5 = n
  → mat_ncols M2 = n
  → mat_ncols M4 = n
  → mat_ncols M6 = n
  → (mat_of_mat_list_list [[M1; M2]; [M3; M4]] *
     mat_of_mat_list_list [[M5]; [M6]])%M =
     mat_of_mat_list_list [[M1 * M5 + M2 * M6]; [M3 * M5 + M4 * M6]]%M.
Proof.
intros * Hs1 Hs3 Hs5 Hr1 Hr2 Hr3 Hr4 Hr5 Hc2 Hc4 Hc6.
specialize (squ_mat_ncols _ Hs1) as Hc1.
apply is_scm_mat_iff in Hs1.
destruct Hs1 as (_ & Hc1').
rewrite Hr1 in Hc1, Hc1'.
specialize (squ_mat_ncols _ Hs3) as Hc3.
apply is_scm_mat_iff in Hs3.
destruct Hs3 as (_ & Hc3').
rewrite Hr3 in Hc3, Hc3'.
specialize (squ_mat_ncols _ Hs5) as Hc5.
apply is_scm_mat_iff in Hs5.
destruct Hs5 as (Hcr5 & Hc5').
rewrite Hr5 in Hc5, Hc5'.
unfold mat_mul, mat_add; cbn.
unfold mat_of_mat_list_list; cbn.
f_equal.
do 3 rewrite app_nil_r.
rewrite app_length.
unfold fold_app_in_list, iter_list; cbn.
do 2 rewrite length_app_in_list.
do 4 rewrite fold_mat_nrows.
rewrite Hr1, Hr2, Hr3, Hr4, Nat.max_id.
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
  now move Hnz at top; subst n.
}
do 2 rewrite map2_map_l, map2_map_r.
do 2 rewrite map2_diag.
apply Nat.neq_0_lt_0 in Hnz.
erewrite map_ext_in. 2: {
  intros i Hi.
  erewrite map_ext_in. 2: {
    intros j Hj.
    unfold mat_ncols in Hj; cbn in Hj.
    rewrite List_app_hd1 in Hj; [ | now rewrite fold_mat_nrows, Hr5 ].
    rewrite fold_mat_ncols, Hc5 in Hj.
    unfold mat_mul_el; cbn.
    unfold mat_ncols; cbn.
    rewrite List_app_hd1. 2: {
      rewrite length_app_in_list.
      do 2 rewrite fold_mat_nrows.
      now rewrite Hr1, Hr2, Nat.max_id.
    }
    rewrite List_hd_nth_0.
    rewrite nth_map3_app; cycle 1. {
      now rewrite fold_mat_nrows, Hr1.
    } {
      now rewrite fold_mat_nrows, Hr2.
    }
    easy.
  }
  easy.
}
rewrite seq_app; cbn.
rewrite map_app.
erewrite map_ext_in. 2: {
  intros i Hi.
  apply in_seq in Hi.
  unfold mat_ncols; cbn.
  rewrite app_nth1. 2: {
    rewrite length_app_in_list.
    do 2 rewrite fold_mat_nrows.
    rewrite Hr1, Hr2, Nat.max_id; flia Hi.
  }
  rewrite List_app_hd1; [ | now rewrite fold_mat_nrows, Hr5 ].
  rewrite List_hd_nth_0.
  rewrite fold_corr_mat_ncols; cycle 1. {
    apply is_scm_mat_iff.
    split; [ easy | now rewrite Hc5 ].
  } {
    now rewrite Hr5.
  }
  rewrite Hc5.
  eapply map_ext_in.
  intros k Hk.
  rewrite app_length.
  do 2 rewrite <- List_hd_nth_0, fold_mat_ncols.
  rewrite Hc1, Hc2.
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    rewrite nth_map3_app; cycle 1. {
      rewrite fold_mat_nrows, Hr1; flia Hi.
    } {
      rewrite fold_mat_nrows, Hr2; flia Hi.
    }
    easy.
  }
  now cbn.
}
cbn.
rewrite Hc5, Hc6.
f_equal. {
  apply map_ext_in.
  intros i Hi.
  rewrite map2_map_l, map2_map_r, map2_diag.
  apply map_ext_in.
  intros k Hk; move k before i.
  unfold mat_mul_el.
  rewrite Hc1, Hc2.
  rewrite (rngl_summation_split n); [ | flia ].
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    rewrite app_nth1. 2: {
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply is_scm_mat_iff.
        split; [ now rewrite Hr1, Hc1 | now rewrite Hc1 ].
      } {
        apply in_seq in Hi; rewrite Hr1; flia Hi.
      }
      rewrite Hc1; flia Hnz Hj.
    }
    rewrite app_nth1. 2: {
      rewrite fold_mat_nrows, Hr5.
      flia Hj Hnz.
    }
    do 2 rewrite fold_mat_el.
    apply in_seq in Hi, Hk.
    rewrite <- Nat.sub_succ_l; [ | flia Hi ].
    rewrite <- Nat.sub_succ_l; [ | flia Hj ].
    rewrite <- Nat.sub_succ_l; [ | flia Hk ].
    do 3 rewrite Nat_sub_succ_1.
    easy.
  }
  f_equal.
  apply in_seq in Hi.
  rewrite (rngl_summation_shift n); [ | flia Hnz ].
  rewrite Nat.add_comm, Nat.add_sub, Nat.add_sub.
  apply rngl_summation_eq_compat.
  intros j Hj.
  rewrite app_nth2. 2: {
    rewrite fold_corr_mat_ncols; cycle 1. {
      apply is_scm_mat_iff.
      split; [ now rewrite Hr1, Hc1 | now rewrite Hc1 ].
    } {
      rewrite Hr1; flia Hi.
    }
    rewrite Hc1; flia Hj.
  }
  rewrite fold_corr_mat_ncols; cycle 1. {
    apply is_scm_mat_iff.
    split; [ now rewrite Hr1, Hc1 | now rewrite Hc1 ].
  } {
    rewrite Hr1; flia Hi.
  }
  rewrite Hc1, fold_mat_el.
  rewrite Nat.add_comm, Nat_sub_sub_swap, Nat.add_sub.
  rewrite <- Nat.sub_succ_l; [ | easy ].
  rewrite <- Nat.sub_succ_l; [ | easy ].
  do 2 rewrite Nat_sub_succ_1.
  f_equal.
  rewrite app_nth2. 2: {
    rewrite fold_mat_nrows, Hr5; flia Hj.
  }
  rewrite fold_mat_nrows, Hr5.
  rewrite Nat_sub_sub_swap, Nat.add_sub.
  rewrite fold_mat_el.
  apply in_seq in Hk.
  rewrite <- Nat.sub_succ_l; [ | easy ].
  rewrite <- Nat.sub_succ_l; [ | easy ].
  now do 2 rewrite Nat_sub_succ_1.
} {
  erewrite List_map_fun with (l' := seq 1 n) (d := 0); [ easy | | ]. {
    now do 2 rewrite seq_length.
  }
  cbn.
  intros i Hi.
  rewrite seq_length in Hi.
  rewrite map2_map_l, map2_map_r.
  unfold mat_ncols; cbn.
  rewrite app_nth2. 2: {
    rewrite seq_nth; [ | easy ].
    rewrite length_app_in_list.
    do 2 rewrite fold_mat_nrows.
    rewrite Hr1, Hr2, Nat.max_id; flia.
  }
  rewrite List_app_hd1; [ | now rewrite fold_mat_nrows, Hr5 ].
  do 2 rewrite <- List_hd_nth_0.
  rewrite fold_mat_ncols, Hc5.
  rewrite map2_diag.
  apply map_ext_in.
  intros k Hk; move k before i.
  rewrite app_length.
  do 2 rewrite fold_mat_ncols.
  rewrite Hc1, Hc2.
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    rewrite seq_nth; [ | easy ].
    rewrite length_app_in_list.
    do 2 rewrite fold_mat_nrows.
    rewrite Hr1, Hr2, Nat.max_id.
    rewrite Nat.add_comm.
    rewrite <- Nat.sub_add_distr, Nat.add_sub.
    rewrite nth_map3_app; cycle 1. {
      now rewrite fold_mat_nrows, Hr3.
    } {
      now rewrite fold_mat_nrows, Hr4.
    }
    easy.
  }
  cbn.
  rewrite (rngl_summation_split n); [ | flia ].
  f_equal. {
    unfold mat_mul_el.
    rewrite Hc3.
    apply rngl_summation_eq_compat.
    intros j Hj.
    rewrite seq_nth; [ | easy ].
    rewrite app_nth1. 2: {
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply is_scm_mat_iff.
        split; [ now rewrite Hr3, Hc3 | now rewrite Hc3 ].
      } {
        now rewrite Hr3.
      }
      rewrite Hc3; flia Hj Hnz.
    }
    rewrite fold_mat_el.
    rewrite <- Nat.sub_succ_l; [ | easy ].
    rewrite Nat_sub_succ_1.
    f_equal.
    rewrite app_nth1. 2: {
      rewrite fold_mat_nrows, Hr5.
      flia Hj Hnz.
    }
    rewrite fold_mat_el.
    apply in_seq in Hk.
    rewrite <- Nat.sub_succ_l; [ | easy ].
    rewrite <- Nat.sub_succ_l; [ | easy ].
    now do 2 rewrite Nat_sub_succ_1.
  } {
    rewrite (rngl_summation_shift n); [ | flia Hnz ].
    rewrite Nat.add_comm, Nat.add_sub, Nat.add_sub.
    unfold mat_mul_el; rewrite Hc4.
    apply rngl_summation_eq_compat.
    intros j Hj.
    rewrite app_nth2. 2: {
      rewrite fold_corr_mat_ncols; cycle 1. {
        apply is_scm_mat_iff.
        split; [ now rewrite Hr3, Hc3 | now rewrite Hc3 ].
      } {
        now rewrite Hr3.
      }
      rewrite Hc3; flia Hj.
    }
    rewrite fold_corr_mat_ncols; cycle 1. {
      apply is_scm_mat_iff.
      split; [ now rewrite Hr3, Hc3 | now rewrite Hc3 ].
    } {
      now rewrite Hr3.
    }
    rewrite Hc3, Nat_sub_sub_swap.
    rewrite Nat.add_comm, Nat.add_sub.
    rewrite fold_mat_el.
    rewrite <- Nat.sub_succ_l; [ | easy ].
    rewrite Nat_sub_succ_1.
    rewrite app_nth2. 2: {
      rewrite fold_mat_nrows, Hr5; flia Hj.
    }
    rewrite fold_mat_nrows, Hr5, Nat_sub_sub_swap.
    now rewrite Nat.add_sub, seq_nth.
  }
}
Qed.

Definition base_vector_1 dim :=
  mk_vect (1%L :: repeat 0%L (dim - 1)).

Definition A_Sn_eigenvector_of_sqrt_Sn n μ (V : vector T) : vector T :=
  (mat_of_mat_list_list [[(mA n + μ × mI (2 ^ n))]; [mI (2 ^ n)]] • V)%M.

Theorem rngl_mul_eq_if : ∀ a b c d, a = c → b = d → (a * b = c * d)%L.
Proof.
intros * Hac Hbd.
now subst a b.
Qed.

Theorem mat_of_mat_list_list_mul_scal_l : ∀ μ mll,
  (μ × mat_of_mat_list_list mll =
   mat_of_mat_list_list (map (map (mat_mul_scal_l μ)) mll))%M.
Proof.
intros.
unfold mat_of_mat_list_list, "×"%M; cbn.
f_equal.
rewrite map_map.
unfold flatten_list_list.
do 2 rewrite flat_map_concat_map.
rewrite concat_map.
do 3 rewrite map_map.
unfold fold_app_in_list, iter_list; cbn.
f_equal.
apply map_ext_in.
intros la Hla.
symmetry.
rewrite List_fold_left_map.
rewrite List_fold_left_map.
symmetry.
cbn.
clear Hla.
assert (H : ∀ lb,
  map (map (rngl_mul μ))
    (fold_left (map3 (app (A:=T))) (map (mat_list_list (T:=T)) la) lb) =
  fold_left
    (λ (c : list (list T)) (b : matrix T),
       map3 (app (A:=T)) c (map (map (rngl_mul μ)) (mat_list_list b))) la
         (map (map (rngl_mul μ)) lb)). {
  induction la as [| a]; intros; [ easy | cbn ].
  rewrite IHla.
  f_equal.
  remember (mat_list_list a) as ll.
  clear Heqll.
  revert lb.
  induction ll as [| lc]; intros. {
    now do 2 rewrite map3_nil_r.
  }
  cbn.
  destruct lb as [| b]; [ easy | cbn ].
  rewrite IHll; f_equal.
  apply map_app.
}
apply H.
Qed.

Theorem is_corr_mat_of_list_list_squ_1_2 : ∀ MA MB,
  mat_nrows MA = mat_nrows MB
  → is_square_matrix MA = true
  → is_square_matrix MB = true
  → is_correct_matrix (mat_of_mat_list_list [[MA]; [MB]]) = true.
Proof.
intros * Hab Ha Hb.
specialize (squ_mat_ncols MA Ha) as Hcan.
specialize (squ_mat_ncols MB Hb) as Hcbn.
remember (mat_nrows MA) as n eqn:Hn.
rename Hn into Hra; rename Hab into Hrb.
symmetry in Hra, Hrb.
rewrite Hrb in Hcbn.
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
  move Hnz at top; subst n.
  apply is_scm_mat_iff in Ha, Hb.
  destruct Ha as (_ & Hca).
  destruct Hb as (_ & Hcb).
  rewrite Hra in Hca; rewrite Hrb in Hcb.
  apply is_scm_mat_iff.
  split. {
    cbn; intros Hc.
    unfold mat_of_mat_list_list; cbn.
    rewrite app_nil_r.
    unfold fold_app_in_list, iter_list; cbn.
    unfold mat_ncols; cbn.
    rewrite app_length.
    do 2 rewrite fold_mat_nrows.
    now rewrite Hra, Hrb.
  } {
    unfold mat_ncols; cbn.
    rewrite app_nil_r.
    unfold fold_app_in_list, iter_list; cbn.
    rewrite List_app_hd2. 2: {
      now rewrite fold_mat_nrows, Hra; unfold "≥".
    }
    cbn.
    rewrite fold_mat_ncols, Hcbn.
    intros l Hl.
    apply in_app_or in Hl.
    destruct Hl as [Hl| Hl]; [ now apply Hca | now apply Hcb ].
  }
}
apply Nat.neq_0_lt_0 in Hnz.
apply is_scm_mat_iff.
split. {
  cbn; intros Hc.
  unfold mat_ncols in Hc.
  unfold mat_of_mat_list_list in Hc; cbn in Hc.
  rewrite List_app_hd1 in Hc. 2: {
    unfold fold_app_in_list, iter_list; cbn.
    rewrite fold_mat_nrows.
    congruence.
  }
  unfold fold_app_in_list, iter_list in Hc; cbn in Hc.
  rewrite fold_mat_ncols in Hc.
  now rewrite <- Hcan, Hc in Hnz.
} {
  intros la Hla.
  unfold mat_ncols; cbn.
  rewrite app_nil_r.
  rewrite List_app_hd1. 2: {
    unfold fold_app_in_list, iter_list; cbn.
    rewrite fold_mat_nrows.
    congruence.
  }
  unfold fold_app_in_list, iter_list; cbn.
  rewrite fold_mat_ncols.
  cbn in Hla.
  unfold fold_app_in_list, iter_list in Hla; cbn in Hla.
  rewrite app_nil_r in Hla.
  apply in_app_or in Hla.
  rewrite Hcan.
  destruct Hla as [Hla| Hla]. {
    apply is_scm_mat_iff in Ha.
    destruct Ha as (_ & Hca).
    rewrite Hra in Hca.
    now apply Hca.
  } {
    apply is_scm_mat_iff in Hb.
    destruct Hb as (_ & Hcb).
    rewrite Hrb in Hcb.
    now apply Hcb.
  }
}
Qed.

Theorem is_corr_mat_of_list_list_1 : ∀ n μ,
  is_correct_matrix
    (mat_of_mat_list_list [[(mA n + μ × mI (2 ^ n))%M]; [mI (2 ^ n)]]) = true.
Proof.
intros.
apply is_corr_mat_of_list_list_squ_1_2. {
  rewrite mat_add_nrows, mA_nrows.
  rewrite mat_mul_scal_l_nrows, mI_nrows.
  apply Nat.min_id.
} {
  apply is_scm_mat_iff; cbn.
  unfold mat_ncols; cbn.
  rewrite map2_length, fold_mat_nrows, mA_nrows.
  do 2 rewrite map_length.
  rewrite seq_length, Nat.min_id.
  rewrite List_hd_nth_0.
  rewrite map2_nth with (a := []) (b := []); cycle 1. {
    rewrite fold_mat_nrows, mA_nrows.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  } {
    do 2 rewrite map_length.
    rewrite seq_length.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  rewrite map2_length.
  rewrite <- List_hd_nth_0, fold_mat_ncols, mA_ncols.
  rewrite (List_map_nth' []). 2: {
    rewrite List_map_seq_length.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  rewrite map_length.
  rewrite (List_map_nth' 0). 2: {
    rewrite seq_length.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  rewrite List_map_seq_length, Nat.min_id.
  split; [ easy | ].
  intros la Hla.
  apply in_map2_iff in Hla.
  destruct Hla as (i & Hi & lb & lc & Hla).
  rewrite fold_mat_nrows, mA_nrows in Hi.
  do 2 rewrite map_length in Hi.
  rewrite seq_length, Nat.min_id in Hi.
  subst la.
  rewrite map2_length.
  rewrite fold_corr_mat_ncols; cycle 1. {
    apply mA_is_correct.
  } {
    now rewrite mA_nrows.
  }
  rewrite mA_ncols.
  rewrite (List_map_nth' []); [ | now rewrite List_map_seq_length ].
  rewrite map_length.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  now rewrite List_map_seq_length, Nat.min_id.
} {
  apply mI_is_square_matrix.
}
Qed.

Theorem mat_ncols_mat_list_list_1_2 : ∀ n μ,
  mat_ncols
    (mat_of_mat_list_list [[(mA n + μ × mI (2 ^ n))%M]; [mI (2 ^ n)]]) =
  2 ^ n.
Proof.
intros.
unfold mat_ncols; cbn.
rewrite app_nil_r.
unfold fold_app_in_list, iter_list; cbn.
rewrite List_app_hd1. 2: {
  rewrite map2_length, fold_mat_nrows, mA_nrows.
  do 2 rewrite map_length.
  rewrite seq_length, Nat.min_id.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
}
rewrite List_hd_nth_0.
rewrite map2_nth with (a := []) (b := []); cycle 1. {
  rewrite fold_mat_nrows, mA_nrows.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
} {
  do 2 rewrite map_length.
  rewrite seq_length.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
}
rewrite map2_length.
rewrite <- List_hd_nth_0.
rewrite fold_mat_ncols, mA_ncols.
rewrite (List_map_nth' []). 2: {
  rewrite List_map_seq_length.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
}
rewrite map_length.
rewrite (List_map_nth' 0). 2: {
  rewrite seq_length.
  now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
}
now rewrite List_map_seq_length, Nat.min_id.
Qed.

Theorem An_eigen_equation_for_sqrt_n :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  rngl_has_inv = true →
  rngl_has_eqb = true →
  ∀ n μ, (μ * μ)%L = rngl_of_nat n →
  match n with
  | 0 => ∀ V, vect_size V = 1 → (mA 0 • V = μ × V)%V
  | S n' =>
      ∀ U V,
      vect_size U = 2 ^ n'
      → V = A_Sn_eigenvector_of_sqrt_Sn n' μ U
      → (mA (S n') • V = μ × V)%V
  end.
Proof.
intros Hic Hop Hin Heq * Hμ.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before Hop.
destruct n. {
  intros V Hv.
  cbn in Hμ, V |-*.
  assert (H : μ = 0%L). {
    remember (rngl_eqb μ 0%L) as μz eqn:Hμz; symmetry in Hμz.
    destruct μz; [ now apply rngl_eqb_eq | ].
    apply rngl_eqb_neq in Hμz; [ | easy ].
    apply (f_equal (rngl_mul (μ⁻¹)%L)) in Hμ.
    rewrite rngl_mul_0_r in Hμ; [ | easy ].
    rewrite rngl_mul_assoc in Hμ.
    rewrite rngl_mul_inv_l in Hμ; [ | easy | easy ].
    now rewrite rngl_mul_1_l in Hμ.
  }
  subst μ.
  apply vector_eq; [ | cbn; rewrite map_length; easy ].
  intros i Hi.
  cbn in Hi.
  replace i with 1 by flia Hi.
  unfold vect_dot_mul; cbn.
  destruct V as (la); cbn.
  destruct la as [| a]; [ easy | ].
  destruct la; [ cbn | easy ].
  unfold vect_dot_mul; cbn.
  unfold iter_list; cbn.
  now rewrite rngl_add_0_l, rngl_mul_0_l.
}
intros * HU HV.
subst V.
unfold A_Sn_eigenvector_of_sqrt_Sn.
rewrite mat_vect_mul_assoc; cycle 1. {
  easy.
} {
  apply mA_is_correct.
} {
  apply is_corr_mat_of_list_list_1.
} {
  rewrite mA_ncols.
  cbn - [ "^" ].
  rewrite app_nil_r.
  rewrite app_length.
  unfold fold_app_in_list, iter_list.
  cbn - [ "^" ].
  rewrite map2_length, fold_mat_nrows, mA_nrows.
  do 2 rewrite map_length.
  rewrite seq_length, Nat.min_id.
  now cbn; rewrite Nat.add_0_r.
} {
  rewrite HU.
  apply mat_ncols_mat_list_list_1_2.
}
rewrite mat_mul_scal_vect_assoc; cycle 1. {
  easy.
} {
  apply is_corr_mat_of_list_list_1.
} {
  rewrite HU.
  apply mat_ncols_mat_list_list_1_2.
}
f_equal; cbn.
rewrite m_o_mll_2x2_2x1 with (n := 2 ^ n); cycle 1. {
  apply mA_is_square_matrix.
} {
  apply mI_is_square_matrix.
} {
  apply squ_mat_add_is_squ. {
    apply mA_is_square_matrix.
  } {
    apply squ_mat_mul_scal_l_is_squ.
    apply mI_is_square_matrix.
  }
} {
  apply mA_nrows.
} {
  apply mI_nrows.
} {
  apply mI_nrows.
} {
  cbn; rewrite map_length.
  apply mA_nrows.
} {
  rewrite mat_add_nrows, mA_nrows.
  rewrite mat_mul_scal_l_nrows, mI_nrows.
  apply Nat.min_id.
} {
  apply mI_ncols.
} {
  unfold mat_ncols; cbn.
  rewrite (List_map_hd []). 2: {
    rewrite fold_mat_nrows, mA_nrows.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  rewrite map_length, fold_mat_ncols.
  apply mA_ncols.
} {
  apply mI_ncols.
}
rewrite mat_of_mat_list_list_mul_scal_l; cbn.
assert (Hcma : is_correct_matrix (mA n) = true) by apply mA_is_correct.
assert (Hcmμi : is_correct_matrix (μ × mI (2 ^ n)) = true). {
  apply is_correct_matrix_mul_scal_l.
  apply mI_is_correct_matrix.
}
assert (Hμir : mat_nrows (μ × mI (2 ^ n)) = 2 ^ n). {
  rewrite mat_mul_scal_l_nrows.
  apply mI_nrows.
}
assert (Hμic : mat_ncols (μ × mI (2 ^ n)) = 2 ^ n). {
  rewrite mat_mul_scal_l_ncols.
  apply mI_ncols.
}
rewrite mat_mul_add_distr_l; [ | easy | easy | | | | ]; cycle 1. {
  rewrite mA_nrows.
  now apply Nat.pow_nonzero.
} {
  now rewrite mA_nrows, mA_ncols.
} {
  now rewrite mA_nrows.
} {
  rewrite mA_ncols.
  rewrite mat_mul_scal_l_ncols.
  symmetry; apply mI_ncols.
}
rewrite lemma_2_A_n_2_eq_n_I; [ | easy ].
rewrite mat_mul_mul_scal_l; [ | easy | easy | | | ]; cycle 1. {
  apply mI_is_correct_matrix.
} {
  rewrite mA_ncols.
  now apply Nat.pow_nonzero.
} {
  now rewrite mA_ncols, mI_nrows.
}
rewrite mat_mul_1_r; [ | easy | easy | symmetry; apply mA_ncols ].
rewrite mat_mul_1_r; [ | easy | | ]; cycle 1. {
  apply mI_is_correct_matrix.
} {
  symmetry; apply mI_ncols.
}
rewrite mat_mul_add_distr_l; [ | easy | easy | | | | ]; cycle 1. {
  rewrite mA_nrows.
  now apply Nat.pow_nonzero.
} {
  now rewrite mI_ncols, mA_nrows.
} {
  now rewrite mA_nrows.
} {
  rewrite mA_ncols.
  now rewrite mat_mul_scal_l_ncols, mI_ncols.
}
rewrite mat_mul_1_l; [ | easy | easy | symmetry; apply mA_nrows ].
rewrite mat_mul_1_l; [ | easy | easy | easy ].
rewrite mat_mul_1_r; [ | easy | | ]; cycle 1. {
  now apply mat_opp_is_correct.
} {
  unfold mat_ncols; cbn.
  rewrite (List_map_hd []). 2: {
    rewrite fold_mat_nrows, mA_nrows.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  rewrite map_length; cbn.
  rewrite fold_mat_ncols.
  symmetry; apply mA_ncols.
}
rewrite fold_mat_sub.
rewrite (mat_add_comm (mA n)).
rewrite mat_add_sub; [ | easy | easy | easy | | ]; cycle 1. {
  now rewrite mA_nrows.
} {
  now rewrite mA_ncols.
}
rewrite mat_add_add_swap.
rewrite mat_mul_scal_l_add_distr_l.
f_equal; f_equal; f_equal; f_equal.
rewrite mat_mul_scal_l_mul_assoc.
rewrite Hμ; cbn.
rewrite mat_add_comm, mat_mul_scal_l_add_distr_r.
now rewrite mat_mul_scal_1_l.
Qed.

Theorem A_n_eigenvalue_squared_is_n :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  rngl_has_eqb = true →
  rngl_has_inv = true →
  ∀ n μ (V : vector T),
  vect_size V = 2 ^ n
  → V ≠ vect_zero (2 ^ n)
  → (mA n • V = μ × V)%V
  → (μ * μ)%L = rngl_of_nat n.
Proof.
intros Hic Hop Heq Hin * Hvs Hvr Hav.
specialize (proj2 rngl_has_inv_or_quot_iff) as Hiq.
specialize (Hiq (or_introl Hin)).
move Hiq before Hin.
specialize (lemma_2_A_n_2_eq_n_I Hop n) as Ha.
specialize (mA_is_correct n) as Hac.
specialize (mI_is_correct_matrix (2 ^ n)) as Hicm.
assert (Hcs : mat_ncols (mA n) = vect_size V) by now rewrite mA_ncols.
(* μ * μ = rngl_of_nat n *)
apply vect_mul_scal_reg_r with (V := V); [ easy | easy | congruence | ].
(* (μ * μ) × V = rngl_of_nat n × V *)
rewrite <- vect_mul_scal_l_mul_assoc; [ | easy ].
(* μ × (μ × V) = rngl_of_nat n × V *)
rewrite <- Hav.
(* μ × (mA n . V) = rngl_of_nat n × V *)
rewrite mat_mul_scal_vect_comm; [ | easy | easy | easy | easy ].
(* mA n . (μ × V) = rngl_of_nat n × V *)
rewrite <- Hav.
(* mA n . (mA n . V) = rngl_of_nat n × V *)
rewrite mat_vect_mul_assoc; [ | easy | easy | easy | | easy ]. 2: {
  now rewrite mA_nrows, mA_ncols.
}
(* (mA n * mA n) . V = rngl_of_nat n × V *)
rewrite Ha.
(* (rngl_of_nat n × mI (2 ^ n)) . V = rngl_of_nat n × V *)
rewrite <- mat_mul_scal_vect_assoc; [ | easy | easy | ]. 2: {
  now rewrite mI_ncols.
}
(* rngl_of_nat n × (mI (2 ^ n) . V) = rngl_of_nat n × V *)
rewrite mat_vect_mul_1_l; easy.
Qed.

Definition is_eigenvector_of_An n μ (V : vector T) :=
  vect_size V = 2 ^ n ∧ V ≠ vect_zero (2 ^ n) ∧ (mA n • V = μ × V)%V.

Theorem μ_is_ev_of_An_iff_μ2_eq_n :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  rngl_has_eqb = true →
  rngl_has_inv = true →
  rngl_characteristic ≠ 1 →
  ∀ n μ,
  (∃ V, is_eigenvector_of_An n μ V) ↔ (μ * μ = rngl_of_nat n)%L.
Proof.
intros Hic Hop Heq Hin H10 *.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before H10.
split. {
  intros HV.
  destruct HV as (V & Hvz & Hv).
  now apply A_n_eigenvalue_squared_is_n with (V := V).
} {
  intros Hμ.
  destruct n. {
    cbn in Hμ |-*.
    unfold is_eigenvector_of_An; cbn.
    exists (base_vector_1 1).
    split; [ easy | ].
    split. {
      intros H.
      injection H; clear H; intros H.
      now apply rngl_1_neq_0_iff in H.
    }
    specialize An_eigen_equation_for_sqrt_n as H1.
    specialize (H1 Hic Hop Hin Heq).
    now apply (H1 0).
  }
  remember (A_Sn_eigenvector_of_sqrt_Sn n μ (base_vector_1 (2 ^ n))) as V
    eqn:Hv.
  exists V.
  split. {
    subst V.
    cbn - [ "^" ].
    rewrite app_nil_r.
    rewrite map_length, app_length.
    unfold fold_app_in_list, iter_list.
    cbn - [ "^" ].
    rewrite map2_length, fold_mat_nrows, mA_nrows.
    do 2 rewrite map_length.
    rewrite seq_length, Nat.min_id.
    now cbn; rewrite Nat.add_0_r.
  }
  split. 2: {
    specialize An_eigen_equation_for_sqrt_n as H1.
    specialize (H1 Hic Hop Hin Heq).
    specialize (H1 (S n) μ Hμ).
    cbn - [ mA ] in H1.
    specialize (H1 (base_vector_1 (2 ^ n)) V).
    cbn in H1.
    rewrite repeat_length in H1.
    rewrite <- Nat.sub_succ_l in H1. 2: {
      now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
    }
    cbn in H1; rewrite Nat.sub_0_r in H1.
    now specialize (H1 eq_refl Hv).
  }
  (* V ≠ vect_zero (2 ^ n) *)
  subst V.
  unfold A_Sn_eigenvector_of_sqrt_Sn.
  unfold mat_of_mat_list_list.
  cbn; rewrite Nat.add_0_r.
  rewrite app_nil_r.
  unfold fold_app_in_list, iter_list.
  cbn.
  intros H.
  injection H; clear H; intros H1.
  rewrite map_app in H1.
  rewrite repeat_app in H1.
  do 2 rewrite map_map in H1.
  apply List_app_eq_app' in H1. 2: {
    rewrite map_length, map2_length, repeat_length.
    rewrite fold_mat_nrows, mA_nrows.
    now rewrite List_map_seq_length, Nat.min_id.
  }
  destruct H1 as (H1, H2).
  rewrite List_repeat_as_map in H2.
  apply ext_in_map with (a := 0) in H2. 2: {
    apply in_seq.
    split; [ easy | ].
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  unfold vect_dot_mul in H2.
  cbn in H2.
  replace (2 ^ n) with (1 + (2 ^ n - 1)) in H2 at 1. 2: {
    rewrite Nat.add_comm.
    apply Nat.sub_add.
    now apply Nat.neq_0_lt_0, Nat.pow_nonzero.
  }
  rewrite seq_app in H2.
  cbn in H2.
  rewrite rngl_mul_1_l in H2.
  rewrite rngl_summation_list_cons in H2.
  rewrite all_0_rngl_summation_list_0 in H2. 2: {
    intros i Hi.
    rewrite <- seq_shift in Hi.
    rewrite map_map in Hi.
    rewrite map2_map_l in Hi.
    rewrite List_repeat_as_map in Hi.
    rewrite map2_map_r in Hi.
    rewrite map2_diag in Hi.
    apply in_map_iff in Hi.
    destruct Hi as (j & Hi & Hj); subst i.
    now apply rngl_mul_0_r.
  }
  rewrite rngl_add_0_r in H2.
  now apply rngl_1_neq_0_iff in H2.
}
Qed.

End a.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (y : natural) (lf2 : natural) : natural :=
  plus y lf2.


(*  implement these *)
Require Import Ascii.
Require Import MyUtils.
Require Import Arith.
(* Require Import Coq.Arith.Bool_nat. *)
Open Scope char_scope.

Notation "# C" := (nat_of_ascii C) (at level 5).

Definition tab := ascii_of_nat 9.
Definition linefeed := ascii_of_nat 10.
Definition carriage_return := ascii_of_nat 13.
Definition space := ascii_of_nat 32.

Definition isUpper (c:ascii) :bool :=
  (le_lt_dec #"A" #c) && (le_lt_dec #c #"Z").

Definition isLower (c:ascii) :bool :=
  (le_lt_dec #"a" #c) && (le_lt_dec #c #"z").

Definition isDigit (c:ascii) :bool :=
  (le_lt_dec #"0" #c) && (le_lt_dec #c #"9").

Definition isAlpha (c:ascii) :bool :=
  (isUpper c) || (isLower c).

Definition isAlphaNum (c:ascii) :bool :=
  (isAlpha c) || (isDigit c).

Definition isHexDigit (c:ascii) :bool :=
  (isDigit c) ||
    ((le_lt_dec #"a" #c) && (le_lt_dec #c #"f")
      || (le_lt_dec #"A" #c) && (le_lt_dec #c #"F")).

Definition isGraph (c:ascii) :bool :=
  (le_lt_dec #"!" #c) && (le_lt_dec #c #"~").

Definition isPrint (c:ascii) :bool :=
  (isGraph c) || (eq_nat_dec #c #" ").

Definition isPunct (c:ascii) :bool :=
  (isGraph c) && (! (isAlphaNum c)).

Definition isCtrl (c:ascii) :bool :=
  ! (isPrint c).

Definition isSpace (c:ascii) :bool :=
  ((le_lt_dec #tab #c) && (le_lt_dec #c #carriage_return)
    || (le_lt_dec #c #" ")).

Definition isNewline (c:ascii) : bool :=
  if (eq_nat_dec #c #carriage_return) then true else false.

Definition toLower (c:ascii) :ascii :=
  if isUpper c
    then (ascii_of_nat (#c + 32))
    else c.

Definition toUpper (c:ascii) :ascii :=
  if isLower c
    then (ascii_of_nat (#c - 32))
    else c.

Lemma lower_imp_alpha : forall (c:ascii), isLower c = true -> isAlpha c = true.
Proof.
  intros c H; unfold isAlpha ; rewrite H ; destruct isUpper ; auto.
Defined.

Lemma lower_imp_alphanum : forall (c:ascii), isLower c = true -> isAlphaNum c = true.
Proof.
  intros c H; unfold isAlphaNum; apply lower_imp_alpha in H; rewrite H; auto.
Defined.

Lemma upper_imp_alpha : forall (c:ascii), isUpper c = true -> isAlpha c = true.
Proof.
  intros c H; unfold isAlpha ; rewrite H ; destruct isLower ; auto.
Defined.

Lemma upper_imp_alphanum : forall (c:ascii), isUpper c = true -> isAlphaNum c = true.
Proof.
  intros c H; unfold isAlphaNum; apply upper_imp_alpha in H; rewrite H; auto.
Defined.


(** * Biased coin program. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Streams Basics QArith String Lqa.
Local Open Scope program_scope.
Local Open Scope string_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From zar Require Import
  compile cotree cocwp cpGCL cpo cwp equidistribution eR misc itree order tactics tree.
Local Open Scope cpGCL_scope.

Require Import prelude.

Definition coin (out : string) (p : Q) : cpGCL :=
  CChoice (const p) (fun b => if b then out <-- true else out <-- false).

Lemma wf_coin (out : string) (p : Q) :
  (0 <= p <= 1)%Q ->
  wf_cpGCL (coin out p).
Proof.
  intros [H0 H1]; constructor; intro; auto.
  destruct b; constructor.
Qed.

(** The probability of assigning `true` to the output variable is
    equal to p. *)
Theorem coin_correct (out : string) (p : Q) :
  (p <= 1)%Q ->
  cwp (coin out p) (fun s => if as_bool (s out) then 1 else 0) empty = Q2eR p.
Proof.
  intro Hp.
  unfold cwp, coin, wp, wlp, const; simpl; eRauto.
  unfold upd; simpl.
  rewrite String.eqb_refl; simpl; eRauto.
Qed.

Section coin_equidistribution.
  Context (env : SamplingEnvironment) (P : St -> bool) (samples : nat -> St).
  Context (out : string) (p : Q) (Hp : (0 <= p <= 1)%Q).
  Hypothesis bitstreams_samples :
    forall i, iproduces (eq (samples i)) (env.(bitstreams) i)
           (cpGCL_to_itree (coin out p) empty).

  Theorem coin_samples_equidistributed :
    converges (freq (is_true ∘ P) ∘ prefix samples)
      (cwp (coin out p) (fun s => if P s then 1 else 0) empty).
  Proof.
    eapply cpGCL_samples_equidistributed; eauto; apply wf_coin; auto.
  Qed.
End coin_equidistribution.

(** Extracting the sampler. *)
From Coq Require Import ExtrOcamlBasic ExtrOcamlString.
Definition sampler (p : Q) : itree boolE bool :=
  ITree.map (fun s => as_bool (s "b")) (cpGCL_to_itree (coin "b" p) empty).
Extraction "extract/coin/coin.ml" sampler.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.

(* Why3 goal *)
Definition div: Z -> Z -> Z.
intros x y.
case (Z_le_dec 0 (Zmod x y)) ; intros H.
exact (Zdiv x y).
exact (Zdiv x y + 1)%Z.
Defined.

(* Why3 goal *)
Definition mod1: Z -> Z -> Z.
intros x y.
exact (x - y * div x y)%Z.
Defined.

(* Why3 goal *)
Lemma Div_mod :
forall (x:Z) (y:Z), (~ (y = 0%Z)) -> (x = ((y * (div x y))%Z + (mod1 x y))%Z).
intros x y Zy.
unfold mod1, div.
case Z_le_dec ; intros H ; ring.
Qed.

(* Why3 goal *)
Lemma Mod_bound :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 ((0%Z <= (mod1 x y))%Z /\ ((mod1 x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
zify.
assert (H1 := Z_mod_neg x y).
assert (H2 := Z_mod_lt x y).
unfold mod1, div.
case Z_le_dec ; intros H0.
rewrite Zmult_comm, <- Zmod_eq_full with (1 := Zy).
omega.
replace (x - y * (x / y + 1))%Z with (x - x / y * y - y)%Z by ring.
rewrite <- Zmod_eq_full with (1 := Zy).
omega.
Qed.

(* Why3 goal *)
Lemma Div_unique :
forall (x:Z) (y:Z) (q:Z),
 (0%Z < y)%Z ->
 ((((q * y)%Z <= x)%Z /\ (x < ((q * y)%Z + y)%Z)%Z) -> ((div x y) = q)).
intros x y q h1 (h2,h3).
assert (h:(~(y=0))%Z) by omega.
generalize (Mod_bound x y h); intro h0.
rewrite Z.abs_eq in h0; auto with zarith.
generalize (Div_mod x y h); clear h; intro h.
assert (cases:(div x y = q \/ (div x y <= q - 1 \/ div x y >= q+1))%Z) by omega.
destruct cases as [h4 | [h5 | h6]]; auto.
assert (y * div x y <= y * (q - 1))%Z.
 apply  Zmult_le_compat_l; auto with zarith.
replace (y*(q-1))%Z with (q*y - y)%Z in H by ring.
elimtype False.
omega.
assert (y * div x y >= y * (q + 1))%Z.
 apply  Zmult_ge_compat_l; auto with zarith.
replace (y*(q+1))%Z with (q*y + y)%Z in H by ring.
elimtype False.
omega.
Qed.

(* Why3 goal *)
Lemma Div_bound :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
 ((0%Z <= (div x y))%Z /\ ((div x y) <= x)%Z).
intros x y (Hx,Hy).
unfold div.
case Z_le_dec ; intros H.
split.
apply Z_div_pos with (2 := Hx).
now apply Zlt_gt.
destruct (Z_eq_dec y 1) as [H'|H'].
rewrite H', Zdiv_1_r.
apply Zle_refl.
rewrite <- (Zdiv_1_r x) at 2.
apply Zdiv_le_compat_l with (1 := Hx).
omega.
elim H.
apply Z_mod_lt.
now apply Zlt_gt.
Qed.

(* Why3 goal *)
Lemma Mod_1 :
forall (x:Z), ((mod1 x 1%Z) = 0%Z).
intros x.
unfold mod1, div.
rewrite Zmod_1_r, Zdiv_1_r, Zmult_1_l.
apply Zminus_diag.
Qed.

(* Why3 goal *)
Lemma Div_1 :
forall (x:Z), ((div x 1%Z) = x).
intros x.
unfold div.
now rewrite Zmod_1_r, Zdiv_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf :
forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (x < y)%Z) -> ((div x y) = 0%Z).
intros x y Hxy.
unfold div.
case Z_le_dec ; intros H.
now apply Zdiv_small.
elim H.
now rewrite Zmod_small.
Qed.

(* Why3 goal *)
Lemma Div_inf_neg :
forall (x:Z) (y:Z),
 ((0%Z < x)%Z /\ (x <= y)%Z) -> ((div (-x)%Z y) = (-1%Z)%Z).
intros x y Hxy.
assert (h: (x < y \/ x = y)%Z) by omega.
destruct h.
(* case 0 < x < y *)
assert (h1: (x mod y = x)%Z).
  rewrite Zmod_small; auto with zarith.
assert (h2: ((-x) mod y = y - x)%Z).
  rewrite Z_mod_nz_opp_full.
  rewrite h1; auto.
rewrite h1; auto with zarith.
unfold div.
case Z_le_dec; auto with zarith.
intros h3.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.

(* case x = y *)
subst.
assert (h1: (y mod y = 0)%Z).
  rewrite Z_mod_same_full; auto with zarith.
assert (h2: ((-y) mod y = 0)%Z).
  rewrite Z_mod_zero_opp_full; auto with zarith.
unfold div.
case Z_le_dec; rewrite h2; auto with zarith.
intro.
rewrite Z_div_zero_opp_full; auto with zarith.
rewrite Z_div_same_full; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_0 :
forall (y:Z), (~ (y = 0%Z)) -> ((mod1 0%Z y) = 0%Z).
intros y Hy.
unfold mod1, div.
rewrite Zmod_0_l.
simpl.
now rewrite Zdiv_0_l, Zmult_0_r.
Qed.

(* Why3 goal *)
Lemma Div_1_left :
forall (y:Z), (1%Z < y)%Z -> ((div 1%Z y) = 0%Z).
intros y Hy.
rewrite Div_inf; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Div_minus1_left :
forall (y:Z), (1%Z < y)%Z -> ((div (-1%Z)%Z y) = (-1%Z)%Z).
intros y Hy.
unfold div.
assert (h1: (1 mod y = 1)%Z).
apply Zmod_1_l; auto.
assert (h2: ((-(1)) mod y = y-1)%Z).
  rewrite Z_mod_nz_opp_full; auto with zarith.
case Z_le_dec; auto with zarith.
intro.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_1_left :
forall (y:Z), (1%Z < y)%Z -> ((mod1 1%Z y) = 1%Z).
intros y Hy.
unfold mod1.
rewrite Div_1_left; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_minus1_left :
forall (y:Z), (1%Z < y)%Z -> ((mod1 (-1%Z)%Z y) = (y - 1%Z)%Z).
intros y Hy.
unfold mod1.
rewrite Div_minus1_left; auto with zarith.
Qed.

Open Scope Z_scope.

(* Why3 goal *)
Lemma Div_mult :
forall (x:Z) (y:Z) (z:Z),
 (0%Z < x)%Z -> ((div ((x * y)%Z + z)%Z x) = (y + (div z x))%Z).
intros x y z h.
unfold div.
destruct (Z_le_dec 0 (z mod x)).
destruct (Z_le_dec 0 ((x*y+z) mod x)).
rewrite Zmult_comm.
rewrite Z_div_plus_full_l; auto with zarith.
generalize (Z_mod_lt (x * y + z) x); auto with zarith.
generalize (Z_mod_lt z x); auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_mult :
forall (x:Z) (y:Z) (z:Z),
 (0%Z < x)%Z -> ((mod1 ((x * y)%Z + z)%Z x) = (mod1 z x)).
intros x y z h.
unfold mod1.
rewrite Div_mult.
ring.
auto with zarith.
Qed.


Require Import Coq.Structures.Equalities.
Require Import Coq.Structures.Orders.
Require Import Coq.QArith.QArith.
Require Import Coq.Classes.Morphisms.

Module Type HasLeEquiv := EqLe' <+ IsEq.

Module Type IsPoset (Import T: HasLeEquiv).
  Axiom refl: Reflexive le.
  Axiom trans: Transitive le.
  Axiom antisym: forall x y, x <= y -> y <= x -> x == y.
  Axiom le_morphism : Proper (eq ==> eq ==> iff) le.
End IsPoset.

Module Type Poset := HasLeEquiv <+ IsPoset.

Open Scope signature_scope.
Module Rat <: Poset.
  Definition t := Q.
  Definition le := Qle.
  Definition eq := Qeq.
  Definition refl := Qle_refl.
  Definition trans := Qle_trans.
  Definition antisym := Qle_antisym.
  Definition eq_equiv := Q_Setoid.
  Definition le_morphism := Qle_comp.
End Rat.

Module PosRat <: Poset.
  Record t_orig := MkPosRat { rat:Q; posrat: (0 <= rat)%Q }.
  Definition t := t_orig.
  Definition le := fun (x y:t) =>  Qle (rat x) (rat y).
  Definition eq := fun (x y:t) =>  Qeq (rat x) (rat y).
  Lemma refl : forall x : t, le x x.
  Proof. intros. unfold le. apply Qle_refl. Qed.
  Lemma trans : forall x y z : t, le x y -> le y z -> le x z.
  Proof. unfold le. intros x y z. apply Qle_trans. Qed.
  Lemma antisym : forall x y : t, le x y -> le y x -> eq x y.
  Proof. unfold le. intros x y. apply Qle_antisym. Qed.
  Lemma eq_refl : Reflexive eq.
  Proof. unfold Reflexive, eq. intros. apply Qeq_refl. Qed.
  Lemma eq_sym : Symmetric eq.
  Proof. unfold Symmetric, eq. intros x y. apply Qeq_sym. Qed.
  Lemma eq_trans : Transitive eq.
  Proof. unfold Transitive, eq. intros x y z. apply Qeq_trans. Qed.
  Definition eq_equiv := (Build_Equivalence eq eq_refl eq_sym eq_trans).
  Lemma le_morphism : Proper (eq ==> eq ==> iff) le.
  Proof.
    unfold Proper, respectful, le, eq.
    intros.
    setoid_rewrite H. setoid_rewrite H0.
    reflexivity.
  Qed.
End PosRat.

Module Type Commonoid (Import P:Poset).
  Parameter f : t -> t -> t.
  Parameter f_unit : t.

  Axiom f_unit_l : forall x, f f_unit x == x.
(*  Axiom f_unit_r : forall x, f x f_unit == x. *)
  Axiom f_incr_l : forall x y z, x <= y -> f x z <= f y z.
  Axiom f_comm: forall x y, f x y == f y x.
  Axiom f_assoc: forall x y z, f x (f y z) == f (f x y) z.
  Axiom f_proper: Proper (eq ==> eq ==> eq) f.
End Commonoid.

Module Commonoid' (Import P : Poset) (Import C : Commonoid P) <: (Commonoid P).
  Definition f := f.
  Definition f_unit := f_unit.
  Definition f_unit_l := f_unit_l.
  Definition f_incr_l := f_incr_l.
  Definition f_comm := f_comm.
  Definition f_assoc := f_assoc.
  Definition f_proper := f_proper.
  Lemma f_unit_r : forall x, f x f_unit == x.
  Proof.
    intros. setoid_rewrite (f_comm x f_unit).
    apply f_unit_l.
  Qed.
  Lemma f_incr_r : forall x y z, x <= y -> f z x <= f z y.
  Proof.
    intros.
    setoid_rewrite (f_comm z x).
    setoid_rewrite (f_comm z y).
    apply (f_incr_l _ _ _ H).
  Qed.
End Commonoid'.

Module Sum (T:Poset) (Com0 : Commonoid T).
  Module Com := Commonoid' T Com0.
  Definition plus := Com.f.
  Definition zero := Com.f_unit.
  Definition plus_0_l := Com.f_unit_l.
  Definition plus_0_r := Com.f_unit_r.
  Definition plus_le_l := Com.f_incr_l.
  Definition plus_le_r := Com.f_incr_r.
  Definition plus_comm := Com.f_comm.
  Definition plus_assoc := Com.f_assoc.
End Sum.

Module Mult (T:Poset) (Com0 : Commonoid T).
  Module Com := Commonoid' T Com0.
  Definition mult := Com.f.
  Definition one := Com.f_unit.
  Definition mult_1_l := Com.f_unit_l.
  Definition mult_1_r := Com.f_unit_r.
  Definition mult_le_l := Com.f_incr_l.
  Definition mult_le_r := Com.f_incr_r.
  Definition mult_comm := Com.f_comm.
  Definition mult_assoc := Com.f_assoc.
End Mult.

Module RatSumCommonoid <: Commonoid Rat.
  Definition f := fun x y => (x + y)%Q.
  Definition f_unit := (0%Q).
  Definition f_unit_l := Qplus_0_l.
  Lemma f_incr_l : forall x y z, (x <= y)%Q -> (f x z <= f y z)%Q.
  Proof.
    intros.
    apply (Qplus_le_compat _ _ _ _ H).
    apply Qle_refl.
  Qed.
  Definition f_comm := Qplus_comm.
  Definition f_assoc := Qplus_assoc.
  Definition f_proper := Qplus_comp.
End RatSumCommonoid.

Module PosRatSumCommonoid <: Commonoid PosRat.
  Import PosRat.
  Infix "≃" := eq (at level 70) : commonoid_rat_scope.
  Infix "⪯" := le (at level 70) : commonoid_rat_scope.
  Open Scope commonoid_rat_scope.

  Lemma sum_of_posrat : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y.
  Proof. intros. rewrite <- Qplus_0_l.
         apply (Qplus_le_compat _ _ _ _ H H0).
  Qed.
  Definition f (x y : t) :=
    MkPosRat ((rat x) + (rat y))
             (sum_of_posrat (rat x) (rat y) (posrat x) (posrat y)).
  Infix "⊕" := f (at level 50) : commonoid_rat_scope.

  Definition f_unit := MkPosRat 0 (Qle_refl 0).
  Lemma f_unit_l : forall x, f_unit ⊕ x ≃ x.
  Proof.
    intros.
    unfold eq, f, f_unit. simpl.
    apply Qplus_0_l.
  Qed.
  Lemma f_incr_l : forall x y z, x ⪯ y -> x ⊕ z ⪯ y ⊕ z.
  Proof.
    unfold le, f. simpl. intros.
    setoid_rewrite (Qplus_le_l (rat x) (rat y) (rat z)).
    assumption.
  Qed.
  Lemma f_comm : forall x y, x ⊕ y ≃ y ⊕ x.
  Proof.
    unfold eq, f. simpl. intros. apply Qplus_comm.
  Qed.
  Lemma f_assoc : forall x y z, x ⊕ (y ⊕ z) ≃ (x ⊕ y) ⊕ z.
  Proof.
    unfold eq, f. simpl. intros.
    apply Qplus_assoc.
  Qed.
  Lemma f_proper : Proper (eq ==> eq ==> eq) f.
  Proof.
    unfold Proper, respectful, eq, f.
    intros. simpl.
    setoid_rewrite H.
    setoid_rewrite H0.
    reflexivity.
  Qed.
End PosRatSumCommonoid.


Require Import BigO.Notation.
Require Import BigO.PartialOrder.Transitivity.
Require Import Coq.Classes.RelationClasses.
Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.interfaces.vectorspace.
Require Import Util.DecField.
Require Util.Admitted.

(**
  Informal proof/overview:

  Assume f,g,h:V→V such that f ∈ Θ(g) and g ∈ Θ(h). Then

  [f ∈ O(h)]
    Proved in another file.

  [f ∈ Ω(h)]
  By assumption,
    - ∃ k_g, n_g such that ∀ n > n_g, k_g * g(n) ≤ f(n)
    - ∃ k_h, n_h such that ∀ n > n_h, k_h * h(n) ≤ g(n)

  then, ∀ n > max(n_g, n_h),
    - k_h * h(n) ≤ g(n)
    - (k_g * k_h) * h(n) ≤ k_g * g(n)
  and
    - k_g * g(n) ≤ f(n)
  so by transitivity of ≤,
    - (k_g * k_h) * h(n) ≤ k_g * g(n) ≤ f(n)
    - (k_g * k_h) * h(n) ≤ ≤ f(n)
  hence, f ∈ Ω(h).
 *)

Section BigThetaTransitivity.
  Context `{SemiNormedSpace K V}.
  Context `{@SemiNormedSpace
              K W1
              Ke Kle Kzero Knegate Kabs Wnorm1 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We1 Wop1 Wunit1 Wnegate1 smkw1
           }.
  Context `{@SemiNormedSpace
              K W2
              Ke Kle Kzero Knegate Kabs Wnorm2 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We2 Wop2 Wunit2 Wnegate2 smkw2
           }.
  Context `{@SemiNormedSpace
              K W3
              Ke Kle Kzero Knegate Kabs Wnorm3 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We3 Wop3 Wunit3 Wnegate3 smkw3
           }.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.

  (* Lemma big_Theta_trans: transitive (V → W) big_Theta. *)
  Lemma big_Theta_trans :
    ∀ (f : V → W1) (g : V → W2) (h : V → W3),
      f ∈ Θ(g) → g ∈ Θ(h) → f ∈ Θ(h).
    unfold transitive.
    intros f g h.
    unfold big_Theta in *.
    intros H_f_g H_g_h. split.
    { (* f ∈ O(h) *)
      now apply (big_O_trans f g h).
    }
    { (* f ∈ Ω(h) *)
      unfold big_Omega.

      (* Unfurl our hypothesis: f ∈ O(g) *)
      destruct H_f_g  as [_ [k_f_g [k_f_g_gt_0 [n0_f_g [n0_f_g_gt_0 HOm_f_g]]]]].
      destruct H_g_h  as [_ [k_g_h [k_g_h_gt_0 [n0_g_h [n0_g_h_gt_0 HOm_g_h]]]]].

      exists (k_f_g * k_g_h).
      split.
      { (* 0 < k_f_g * k_g_h *)
        apply mult_pos_gt_0;
          assumption.
      }
      {
        exists (n0_f_g + n0_g_h).

        split.
        { (* 0 < n0_f_g + n0_g_h *)
          apply semirings.plus_lt_compat_r; assumption.
        }
        {
          intros n'.

          (* Prove that our new n_0 is greater than the previous *)
          intros n_ge_n0.
          assert (n_ge_n0_f_g : n0_f_g ≤ ∥n'∥) by
              (now apply (DecField.plus_le n0_f_g n0_g_h)).
          assert (n_ge_n0_g_h : n0_g_h ≤ ∥n'∥) by
              (rewrite commutativity in n_ge_n0;
               now apply (DecField.plus_le n0_g_h n0_f_g)).
          clear n_ge_n0.

          assert (fn_le_gn : (k_f_g * ∥g n'∥) ≤ ∥f n'∥) by (now apply HOm_f_g).
          assert (gn_le_hn : (k_g_h * ∥h n'∥) ≤ ∥g n'∥) by (now apply HOm_g_h).

          clear HOm_f_g HOm_g_h.

          transitivity (k_f_g * ∥g n'∥); try assumption.
          rewrite <- associativity.
          rewrite (order_preserving_mult_le (k_g_h * ∥h n'∥) (∥g n'∥));
            now try assumption.
        }
      }
    }
  Qed.
End BigThetaTransitivity.


Require Import Basics.
Require Import DbLib.DeBruijn.
Require Import DbLib.Environments.
Require Export Compare_dec.

Lemma raw_insert_eq_insert_1:
  forall A x a1 a2 (e1 e2 : env A),
  raw_insert x a1 e1 = raw_insert x a2 e2 ->
  a1 = a2.
Proof with eauto.
  induction x.
  Case "x = 0".
    intros a1 a2 e1 e2 RI.
    rewrite raw_insert_zero in RI.
    rewrite raw_insert_zero in RI.
    inversion RI...
  Case "x = Suc _".
    intros a1 a2 e1 e2 RI.
    rewrite raw_insert_successor in RI.
    rewrite raw_insert_successor in RI.
    inversion RI...
Qed.

(* These are some safe utility lemmas about DbLib *)
Lemma lookup_zero_nil : forall A,
  lookup 0 [] = @None A.
Proof. auto. Qed.

Lemma lookup_zero_cons : forall A (E : env A) e,
  lookup 0 (e :: E) = e.
Proof. eauto. Qed.

Lemma lookup_succ_cons : forall A (E : env A) e x,
  lookup (S x) (e :: E) = lookup x E.
Proof. eauto. Qed.

Global Opaque empty.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Cpo.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Ensembles.
Require Export Relations_1.
Require Export Partial_Order.

Section Bounds.
  Variable U : Type.
  Variable D : PO U.

  Let C := Carrier_of U D.

  Let R := Rel_of U D.

  Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
    Upper_Bound_definition :
    In U C x -> (forall y:U, In U B y -> R y x) -> Upper_Bound B x.

  Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
    Lower_Bound_definition :
    In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.

  Inductive Lub (B:Ensemble U) (x:U) : Prop :=
    Lub_definition :
    Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.

  Inductive Glb (B:Ensemble U) (x:U) : Prop :=
    Glb_definition :
    Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.

  Inductive Bottom (bot:U) : Prop :=
    Bottom_definition :
    In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.

  Inductive Totally_ordered (B:Ensemble U) : Prop :=
    Totally_ordered_definition :
    (Included U B C ->
      forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) ->
    Totally_ordered B.

  Definition Compatible : Relation U :=
    fun x y:U =>
      In U C x ->
      In U C y ->  exists z : _, In U C z /\ Upper_Bound (Couple U x y) z.

  Inductive Directed (X:Ensemble U) : Prop :=
    Definition_of_Directed :
    Included U X C ->
    Inhabited U X ->
    (forall x1 x2:U,
      Included U (Couple U x1 x2) X ->
      exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
    Directed X.

  Inductive Complete : Prop :=
    Definition_of_Complete :
    (exists bot : _, Bottom bot) ->
    (forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
    Complete.

  Inductive Conditionally_complete : Prop :=
    Definition_of_Conditionally_complete :
    (forall X:Ensemble U,
      Included U X C ->
      (exists maj : _, Upper_Bound X maj) ->
      exists bsup : _, Lub X bsup) -> Conditionally_complete.
End Bounds.

Hint Resolve Totally_ordered_definition Upper_Bound_definition
  Lower_Bound_definition Lub_definition Glb_definition Bottom_definition
  Definition_of_Complete Definition_of_Complete
  Definition_of_Conditionally_complete.

Section Specific_orders.
  Variable U : Type.

  Record Cpo : Type := Definition_of_cpo
    {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.

  Record Chain : Type := Definition_of_chain
    {PO_of_chain : PO U;
    Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.

End Specific_orders.


(* Project files imports *)
Require Import MyLists.
Require Import Sequent_Calculus.
Require Import Basic_Properties.
Require Import Cut_One.
Require Import Cut_Atom.
Require Import Cut_Tensor.
Require Import Cut_Lolli.
Require Import Cut_With.
Require Import Cut_Oplus.

(* Other imports *)
From Coq Require Import Arith.Arith.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.

Theorem cut_admissibility : forall
    (n m : nat)
    (A C : formula)
    (Gamma Delta1 Delta2 : list formula),
    n; Gamma |- A ->
    m; (Delta1 ++ [A] ++ Delta2) |- C ->
    exists z,
       z; (Gamma ++ Delta1 ++ Delta2) |- C.
Proof.
  intros n m A.
  generalize dependent m.
  generalize dependent n.

  (* We first do induction on A *)
  (* The IH on A is used for Cut Reductions *)
  induction A.

  (* A is One -- Proven by Lemma cut_one *)
  - apply cut_one.

  (* A is Atom a -- Proven by Lemma cut_atom *)
  - intros n m.
    apply (cut_atom n m a).

  (* A is A ** B -- Proven by Lemma cut_tensor *)
  - apply (cut_tensor A1 A2 IHA1 IHA2).

  (* A is A -o B -- Proven by Lemma cut_lolli *)
  - apply (cut_lolli A1 A2 IHA1 IHA2).

  (* A is A # B -- Proven by Lemma cut_oplus*)
  - apply (cut_oplus A1 A2 IHA1 IHA2).

  (* A is A & B -- Proven by Lemma cut_with*)
  - apply (cut_with A1 A2 IHA1 IHA2).

Qed.


Require Coq.Arith.Compare_dec.

Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.Arith.Peano_dec.
Require Import Omega.

Require Import Aniceto.Map.

Require Coq.FSets.FMapFacts.

Inductive tid := taskid : nat -> tid.

Definition tid_nat r := match r with | taskid n => n end.

Definition tid_first := taskid 0.

Definition tid_next m := taskid (S (tid_nat m)).

Module TID <: UsualOrderedType.
  Definition t := tid.
  Definition eq := @eq tid.
  Definition lt x y := lt (tid_nat x) (tid_nat y).
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Lemma lt_trans: forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros.
    unfold lt in *.
    destruct x, y, z.
    simpl in *.
    omega.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> x <> y.
  Proof.
    unfold lt in *.
    intros.
    destruct x, y.
    simpl in *.
    unfold not; intros.
    inversion H0.
    subst.
    apply Lt.lt_irrefl in H.
    inversion H.
  Qed.

  Import Coq.Arith.Compare_dec.
  Lemma compare:
    forall x y, Compare lt Logic.eq x y.
  Proof.
    intros.
    destruct x, y.
    destruct (Nat_as_OT.compare n n0);
    eauto using LT, GT.
    apply EQ.
    unfold Nat_as_OT.eq in *.
    subst.
    intuition.
  Defined.

  Lemma eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    intros.
    unfold eq.
    destruct x, y.
    destruct (eq_nat_dec n n0).
    - subst; eauto.
    - right.
      unfold not.
      intros.
      contradiction n1.
      inversion H; auto.
  Defined.
End TID.

Module Map_TID := FMapAVL.Make TID.
Module Map_TID_Facts := FMapFacts.Facts Map_TID.
Module Map_TID_Props := FMapFacts.Properties Map_TID.
Module Map_TID_Extra := MapUtil Map_TID.
Module Set_TID := FSetAVL.Make TID.
Definition set_tid := Set_TID.t.
Lemma tid_eq_rw:
  forall (k k':tid), TID.eq k k' <-> k = k'.
Proof.
  intros.
  auto with *.
Qed.

Section NotIn.
  Variable elt:Type.

  Let lt_irrefl:
    forall x : tid, ~ TID.lt x x.
  Proof.
    unfold not; intros.
    apply TID.lt_not_eq in H.
    contradiction H.
    apply TID.eq_refl.
  Qed.

  Let lt_next:
    forall x, TID.lt x (tid_next x).
  Proof.
    intros.
    destruct x.
    unfold tid_next, tid_nat, TID.lt.
    simpl.
    auto.
  Qed.

  Let tid_impl_eq:
    forall k k' : tid, k = k' -> k = k'.
  Proof.
    auto.
  Qed.

  Definition supremum {elt:Type} := @Map_TID_Extra.supremum elt tid_first tid_next TID.lt TID.compare.

  Theorem find_not_in:
    forall (m: Map_TID.t elt),
    ~ Map_TID.In (supremum m) m.
  Proof.
    intros.
    eauto using Map_TID_Extra.find_not_in, TID.lt_trans.
  Qed.

End NotIn.


(**
*  CS386L Programming Languages
* Final project
* Tian Zhang (tz3272)
* Brief Introduction:
*     For this file, I am working on constant folding, and
      all the work is based on Maps, Imp in class. I got some idea from
      the book
*)

Require Import ProgramEquivalence.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.
Require Import Maps.
Require Import Imp.

(** before partial evalation, the first part I want to implement
  a more simple idea, constant folding

  An expression is constant when it contains no variable
  references. Constant folding is an optimization that finds constant
  expressions and replaces them by their values.

  Some definition and proof idea is followed equiv.v in the software
  foundation book
*)

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i        => AId i
  | APlus a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => APlus a1' a2'
    end
  | AMinus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => AMinus a1' a2'
    end
  | AMult a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => AMult a1' a2'
    end
  end.

(** Example, fold 1 + 2 => 3 *)
Example fold_aexp_ex1 :
    fold_constants_aexp
      (AMult (APlus (ANum 1) (ANum 2)) (AId X))
  = AMult (ANum 3) (AId X).
Proof. reflexivity. Qed.

(** we can also fold boolean expression , if we find constant boolean expression
    we can evaluate in place *)

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue        => BTrue
  | BFalse       => BFalse
  | BEq a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) =>
        if beq_nat n1 n2 then BTrue else BFalse
    | (a1', a2') =>
        BEq a1' a2'
    end
  | BLe a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) =>
        if leb n1 n2 then BTrue else BFalse
    | (a1', a2') =>
        BLe a1' a2'
    end
  | BNot b1  =>
    match (fold_constants_bexp b1) with
    | BTrue => BFalse
    | BFalse => BTrue
    | b1' => BNot b1'
    end
  | BAnd b1 b2  =>
    match (fold_constants_bexp b1, fold_constants_bexp b2)
    with
    | (BTrue, BTrue) => BTrue
    | (BTrue, BFalse) => BFalse
    | (BFalse, BTrue) => BFalse
    | (BFalse, BFalse) => BFalse
    | (b1', b2') => BAnd b1' b2'
    end
  end.

Example fold_bexp_ex1 :
    fold_constants_bexp (BAnd BTrue (BNot (BAnd BFalse BTrue)))
  = BTrue.
Proof. reflexivity. Qed.

(** the next step is to fold constant in command*)

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      CAss i (fold_constants_aexp a)
  | c1 ;; c2  =>
      (fold_constants_com c1) ;; (fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

(** Example *)
Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    (X ::= APlus (ANum 4) (ANum 5);;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y))
             (APlus (ANum 2) (ANum 4)) THEN
       SKIP
     ELSE
       Y ::= ANum 0
     FI;;
     IFB BLe (ANum 0)
             (AMinus (ANum 4) (APlus (ANum 2) (ANum 1)))
     THEN
       Y ::= ANum 0
     ELSE
       SKIP
     FI;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END)
  = (* After constant folding: *)
    (X ::= ANum 9;;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y)) (ANum 6) THEN
       SKIP
     ELSE
       (Y ::= ANum 0)
     FI;;
     Y ::= ANum 0;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END).
Proof. reflexivity. Qed.

(** Now we have constant folding, we need to prove that, after folding,
  the program is correct, we already prove the program equivalence in
  programEquivalence , and we will use it to prove constant folding
  is correct
*)

(** A program transformation is sound if it preserves the
    behavior of the original program. *)

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

(** The prove has 3 parts, for aexp, bexp and command *)

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound. intros a. unfold aequiv. intros st.
  induction a; simpl;
    try reflexivity;
    try (destruct (fold_constants_aexp a1);
         destruct (fold_constants_aexp a2);
         rewrite IHa1; rewrite IHa2; reflexivity).
Qed.

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv. intros st.
  induction b;

    try reflexivity.
  - rename a into a1. rename a0 into a2. simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
    simpl. destruct (beq_nat n n0); reflexivity.
  - (* BLe *)
    rename a into a1. rename a0 into a2. simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
      (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
      (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; auto.
    simpl. destruct ( n <=? n0); auto.
  - (* BNot *)
    simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - (* BAnd *)
    simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; simpl; try reflexivity
    ; eauto using andb_true_l, andb_true_r, andb_false_l, andb_false_r.
Qed.

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  induction c; simpl.
  - (* SKIP *) apply refl_cequiv.
  - (* ::= *) apply CAss_congruence.
              apply fold_constants_aexp_sound.
  - (* ;; *) apply CSeq_congruence; assumption.
  - (* IFB *)
    assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).

    + (* b always true *)
      apply trans_cequiv with c1; try assumption.
      apply IFB_true; assumption.
    + (* b always false *)
      apply trans_cequiv with c2; try assumption.
      apply IFB_false; assumption.
  - (* WHILE *)
    assert (bequiv b (fold_constants_bexp b)).
    apply fold_constants_bexp_sound.
    destruct (fold_constants_bexp b) eqn:Hb; try (apply CWhile_congruence; assumption; assumption).
    apply WHILE_true with (c:=c) in H.
    assumption.
    apply WHILE_false with (c:=c) in H.
    assumption.
Qed.