Require Import init.

Require Export tensor_algebra_defs.
Require Export tensor_algebra_base.
Require Import algebra_category.
Require Import linear_span.
Require Import linear_subspace.
Require Import linear_grade_sum.
Require Import linear_extend.

Require Import nat.
Require Import list.
Require Import unordered_list.

Section TensorAlgebraGrade.

Context {F : CRingObj} (V : ModuleObj F).
Let U := cring_U F.

Section Single.

Variable n : nat.

Definition tensor_n_base (X : algebra_V (tensor_algebra V)) :=
    ∃ l, X = list_prod (list_image vector_to_tensor l) ∧ list_size l = n.

Definition tensor_n_subspace := linear_span_subspace (cring_U F) tensor_n_base.

Definition tensor_n_module := make_module
    F
    (set_type (subspace_set tensor_n_subspace))
    (subspace_plus_class _)
    (subspace_zero_class _)
    (subspace_neg_class _)
    (subspace_plus_assoc _)
    (subspace_plus_comm _)
    (subspace_plus_lid _)
    (subspace_plus_linv _)
    (subspace_scalar_class _)
    (subspace_scalar_id _)
    (subspace_scalar_ldist _)
    (subspace_scalar_rdist _)
    (subspace_scalar_comp _)
.

End Single.

Definition tensor_n_algebra_module := grade_sum nat tensor_n_module.

Definition tensor_n_grade := grade_sum_grade nat tensor_n_module
    : GradedSpace U (module_V tensor_n_algebra_module).
Local Existing Instances tensor_n_grade.

Definition to_tensor_n {k} (X : module_V (tensor_n_module k))
    := single_to_grade_sum nat tensor_n_module X
    : module_V tensor_n_algebra_module.

Definition to_tensor_n_k {m n : nat} (eq : m = n)
    (X : module_V (tensor_n_module m)) : module_V (tensor_n_module n).
Proof.
    rewrite <- eq.
    exact X.
Defined.

Lemma to_tensor_n_k_eq {m n : nat} (eq : m = n) :
    ∀ X : module_V (tensor_n_module m), to_tensor_n X =
    to_tensor_n (to_tensor_n_k eq X).
Proof.
    intros X.
    unfold to_tensor_n_k.
    destruct eq; cbn.
    reflexivity.
Qed.

Lemma to_tensor_n_eq : ∀ {k} a b AH BH, a = b →
    to_tensor_n (k := k) [a|AH] = to_tensor_n (k := k) [b|BH].
Proof.
    intros k a b AH BH eq.
    apply f_equal.
    apply set_type_eq; cbn.
    exact eq.
Qed.

Theorem to_tensor_n_plus : ∀ {k} (u v : module_V (tensor_n_module k)),
    to_tensor_n (u + v) = to_tensor_n u + to_tensor_n v.
Proof.
    intros k u v.
    unfold to_tensor_n.
    apply single_to_grade_sum_plus.
Qed.

Theorem to_tensor_n_scalar : ∀ {k} a (v : module_V (tensor_n_module k)),
    to_tensor_n (a · v) = a · to_tensor_n v.
Proof.
    intros k a v.
    unfold to_tensor_n.
    apply single_to_grade_sum_scalar.
Qed.

Lemma vector_to_tensor_n_in :
    ∀ v, subspace_set (tensor_n_subspace 1) (vector_to_tensor v).
Proof.
    intros v.
    cbn.
    rewrite (span_linear_combination U).
    assert (linear_combination_set
        ((one (U := U), vector_to_tensor v) ː ulist_end)) as comb.
    {
        unfold linear_combination_set.
        rewrite ulist_image_add.
        rewrite ulist_image_end.
        apply ulist_unique_single.
    }
    exists [_|comb].
    split.
    -   unfold linear_combination; cbn.
        rewrite ulist_image_add, ulist_sum_add; cbn.
        rewrite ulist_image_end, ulist_sum_end.
        rewrite scalar_id, plus_rid.
        reflexivity.
    -   unfold linear_list_in; cbn.
        rewrite ulist_prop_add; cbn.
        split; [>|apply ulist_prop_end].
        exists [v].
        split.
        +   rewrite list_image_single.
            rewrite list_prod_single.
            reflexivity.
        +   reflexivity.
Qed.

Definition vector_to_tensor_n (v : module_V V) :=
    to_tensor_n [vector_to_tensor v | vector_to_tensor_n_in v]
    : module_V tensor_n_algebra_module.

Theorem vector_to_tensor_n_plus : ∀ u v,
    vector_to_tensor_n (u + v) = vector_to_tensor_n u + vector_to_tensor_n v.
Proof.
    intros u v.
    unfold vector_to_tensor_n.
    rewrite <- to_tensor_n_plus.
    apply f_equal.
    unfold plus at 3; cbn.
    apply set_type_eq; cbn.
    apply vector_to_tensor_plus.
Qed.

Theorem vector_to_tensor_n_scalar : ∀ a v,
    vector_to_tensor_n (a · v) = a · vector_to_tensor_n v.
Proof.
    intros a v.
    unfold vector_to_tensor_n.
    rewrite <- to_tensor_n_scalar.
    apply f_equal.
    unfold scalar_mult at 3; cbn.
    apply set_type_eq; cbn.
    apply vector_to_tensor_scalar.
Qed.

Lemma tensor_n_algebra_mult_in : ∀ m n a b,
    subspace_set (tensor_n_subspace m) a → subspace_set (tensor_n_subspace n) b
    → subspace_set (tensor_n_subspace (m + n)) (a * b).
Proof.
    intros m n a b a_in b_in.
    cbn in *.
    rewrite (span_linear_combination U) in *.
    destruct a_in as [[u u_comb] [a_eq u_in]]; subst a.
    destruct b_in as [[v v_comb] [b_eq v_in]]; subst b.
    unfold linear_list_in in *; cbn in *.
    unfold linear_combination; cbn.
    clear u_comb v_comb.
    induction u as [|a u] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite mult_lanni.
        apply linear_combination_of_zero.
    }
    rewrite ulist_prop_add in u_in.
    destruct u_in as [a_in u_in].
    specialize (IHu u_in).
    rewrite ulist_image_add, ulist_sum_add.
    rewrite rdist.
    apply linear_combination_of_plus; [>|exact IHu].
    clear u u_in IHu.
    induction v as [|b v] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite mult_ranni.
        apply linear_combination_of_zero.
    }
    rewrite ulist_prop_add in v_in.
    destruct v_in as [b_in v_in].
    specialize (IHv v_in).
    rewrite ulist_image_add, ulist_sum_add.
    rewrite ldist.
    apply linear_combination_of_plus; [>|exact IHv].
    clear v v_in IHv.
    destruct a as [α a], b as [β b]; cbn in *.
    rewrite scalar_lmult, scalar_rmult.
    do 2 apply linear_combination_of_scalar.
    destruct a_in as [u [a_eq u_size]]; subst a.
    destruct b_in as [v [b_eq v_size]]; subst b.
    assert (linear_combination_set ((one (U := U), list_prod
        (list_image vector_to_tensor (u + v))) ː ulist_end)) as comb.
    {
        unfold linear_combination_set.
        rewrite ulist_image_add, ulist_image_end.
        cbn.
        apply ulist_unique_single.
    }
    exists [_|comb].
    split.
    -   unfold linear_combination.
        rewrite ulist_image_add, ulist_image_end.
        cbn.
        rewrite ulist_sum_add, ulist_sum_end.
        rewrite scalar_id, plus_rid.
        rewrite list_image_conc.
        rewrite list_prod_mult.
        reflexivity.
    -   unfold linear_list_in; cbn.
        rewrite ulist_prop_add.
        split; [>|apply ulist_prop_end].
        cbn.
        exists (u + v).
        split; [>reflexivity|].
        rewrite <- u_size, <- v_size.
        apply list_size_conc.
Qed.

Definition tensor_n_mult_base i j
    (a : module_V tensor_n_algebra_module)
    (b : module_V tensor_n_algebra_module)
    (ai : of_grade i a) (bj : of_grade j b)
    := to_tensor_n
        [[ex_val ai|] * [ex_val bj|] |
            tensor_n_algebra_mult_in i j [ex_val ai|] [ex_val bj|]
                [|ex_val ai] [|ex_val bj]].

Lemma tensor_n_mult_tm : ∀ i j a b AH BH,
    tensor_n_mult_base i j (to_tensor_n a) (to_tensor_n b) AH BH
    = to_tensor_n [[a|] * [b|] |
        tensor_n_algebra_mult_in i j [a|] [b|] [|a] [|b]].
Proof.
    intros i j a b AH BH.
    unfold tensor_n_mult_base.
    rewrite_ex_val a' a'_eq.
    rewrite_ex_val b' b'_eq.
    unfold to_tensor_n in a'_eq, b'_eq.
    apply single_to_grade_sum_eq in a'_eq, b'_eq.
    subst a' b'.
    reflexivity.
Qed.

Theorem tensor_n_mult_base_ldist :
    bilinear_extend_ldist_base tensor_n_mult_base.
Proof.
    intros u' v' w' i j iu jv jw.
    pose proof iu as [u u_eq].
    pose proof jv as [v v_eq].
    pose proof jw as [w w_eq].
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := i)) in u_eq.
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := j)) in v_eq, w_eq.
    subst u' v' w'.
    assert (of_grade j (to_tensor_n (v + w))) as vwj.
    {
        unfold to_tensor_n.
        rewrite single_to_grade_sum_plus.
        apply of_grade_plus; assumption.
    }
    rewrite (bilinear_extend_base_req _ _ _ _ _ _ _ _ vwj)
        by (symmetry; apply single_to_grade_sum_plus).
    do 3 rewrite tensor_n_mult_tm.
    unfold to_tensor_n.
    rewrite <- single_to_grade_sum_plus.
    apply f_equal.
    unfold plus at 6; cbn.
    apply set_type_eq; cbn.
    apply ldist.
Qed.

Theorem tensor_n_mult_base_rdist :
    bilinear_extend_rdist_base tensor_n_mult_base.
Proof.
    intros u' v' w' i j iu iv jw.
    pose proof iu as [u u_eq].
    pose proof iv as [v v_eq].
    pose proof jw as [w w_eq].
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := i)) in u_eq, v_eq.
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := j)) in w_eq.
    subst u' v' w'.
    assert (of_grade i (to_tensor_n (u + v))) as uvi.
    {
        unfold to_tensor_n.
        rewrite single_to_grade_sum_plus.
        apply of_grade_plus; assumption.
    }
    rewrite (bilinear_extend_base_leq _ _ _ _ _ _ _ uvi)
        by (symmetry; apply single_to_grade_sum_plus).
    do 3 rewrite tensor_n_mult_tm.
    unfold to_tensor_n.
    rewrite <- single_to_grade_sum_plus.
    apply f_equal.
    unfold plus at 6; cbn.
    apply set_type_eq; cbn.
    apply rdist.
Qed.

Theorem tensor_n_mult_base_lscalar :
    bilinear_extend_lscalar_base tensor_n_mult_base.
Proof.
    intros a u' v' i j iu jv.
    pose proof iu as [u u_eq].
    pose proof jv as [v v_eq].
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := i)) in u_eq.
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := j)) in v_eq.
    subst u' v'.
    assert (of_grade i (to_tensor_n (a · u))) as aui.
    {
        unfold to_tensor_n.
        rewrite single_to_grade_sum_scalar.
        apply of_grade_scalar; assumption.
    }
    rewrite (bilinear_extend_base_leq _ _ _ _ _ _ _ aui)
        by (symmetry; apply single_to_grade_sum_scalar).
    do 2 rewrite tensor_n_mult_tm.
    unfold to_tensor_n.
    rewrite <- single_to_grade_sum_scalar.
    apply f_equal.
    unfold scalar_mult at 4; cbn.
    apply set_type_eq; cbn.
    apply scalar_lmult.
Qed.

Theorem tensor_n_mult_base_rscalar :
    bilinear_extend_rscalar_base tensor_n_mult_base.
Proof.
    intros a u' v' i j iu jv.
    pose proof iu as [u u_eq].
    pose proof jv as [v v_eq].
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := i)) in u_eq.
    change (single_to_grade_sum nat tensor_n_module)
        with (to_tensor_n (k := j)) in v_eq.
    subst u' v'.
    assert (of_grade j (to_tensor_n (a · v))) as avj.
    {
        unfold to_tensor_n.
        rewrite single_to_grade_sum_scalar.
        apply of_grade_scalar; assumption.
    }
    rewrite (bilinear_extend_base_req _ _ _ _ _ _ _ _ avj)
        by (symmetry; apply single_to_grade_sum_scalar).
    do 2 rewrite tensor_n_mult_tm.
    unfold to_tensor_n.
    rewrite <- single_to_grade_sum_scalar.
    apply f_equal.
    unfold scalar_mult at 4; cbn.
    apply set_type_eq; cbn.
    apply scalar_rmult.
Qed.

Instance tensor_n_mult : Mult (module_V tensor_n_algebra_module) := {
    mult A B := bilinear_extend tensor_n_mult_base A B
}.

Local Instance tensor_n_mult_ldist : Ldist (module_V tensor_n_algebra_module).
Proof.
    split.
    apply bilinear_extend_ldist.
    -   apply tensor_n_mult_base_ldist.
    -   apply tensor_n_mult_base_rscalar.
Qed.
Local Instance tensor_n_mult_rdist : Rdist (module_V tensor_n_algebra_module).
Proof.
    split.
    apply bilinear_extend_rdist.
    -   apply tensor_n_mult_base_rdist.
    -   apply tensor_n_mult_base_lscalar.
Qed.
Local Instance tensor_n_scalar_lmult
    : ScalarLMult U (module_V tensor_n_algebra_module).
Proof.
    split.
    apply bilinear_extend_lscalar.
    -   apply tensor_n_mult_base_rdist.
    -   apply tensor_n_mult_base_lscalar.
Qed.
Local Instance tensor_n_scalar_rmult
    : ScalarRMult U (module_V tensor_n_algebra_module).
Proof.
    split.
    apply bilinear_extend_rscalar.
    -   apply tensor_n_mult_base_ldist.
    -   apply tensor_n_mult_base_rscalar.
Qed.

Theorem to_tensor_n_mult : ∀ m n a b
    (ma : subspace_set (tensor_n_subspace m) a)
    (nb : subspace_set (tensor_n_subspace n) b),
    to_tensor_n [a|ma] * to_tensor_n [b|nb] =
    to_tensor_n [a * b|tensor_n_algebra_mult_in m n a b ma nb].
Proof.
    intros m n a b ma nb.
    unfold mult at 1; cbn.
    assert (of_grade (H9 := tensor_n_grade) m (to_tensor_n [a|ma])) as ma'.
    {
        exists [a|ma].
        reflexivity.
    }
    assert (of_grade (H9 := tensor_n_grade) n (to_tensor_n [b|nb])) as nb'.
    {
        exists [b|nb].
        reflexivity.
    }
    rewrite (bilinear_extend_homo _
        tensor_n_mult_base_ldist tensor_n_mult_base_rdist
        tensor_n_mult_base_lscalar tensor_n_mult_base_rscalar _ _ _ _ ma' nb').
    rewrite tensor_n_mult_tm; cbn.
    reflexivity.
Qed.

Instance tensor_n_grade_mult : GradedAlgebraObj U (module_V tensor_n_algebra_module).
Proof.
    split.
    intros u' v' i j iu vj.
    destruct iu as [u u_eq]; subst u'.
    destruct vj as [v v_eq]; subst v'.
    destruct u as [u u_in], v as [v v_in].
    rewrite to_tensor_n_mult.
    pose proof (tensor_n_algebra_mult_in _ _ _ _ u_in v_in) as uv_in.
    exists [_|uv_in].
    apply f_equal.
    apply set_type_eq; reflexivity.
Qed.

Lemma tensor_n_one_in : subspace_set (tensor_n_subspace 0) 1.
Proof.
    cbn.
    rewrite (span_linear_combination U).
    assert (linear_combination_set ((one (U := U),
        one (U := algebra_V (tensor_algebra V))) ː ulist_end)) as comb.
    {
        unfold linear_combination_set.
        rewrite ulist_image_add.
        rewrite ulist_image_end.
        apply ulist_unique_single.
    }
    exists [_|comb].
    split.
    -   unfold linear_combination; cbn.
        rewrite ulist_image_add, ulist_sum_add; cbn.
        rewrite ulist_image_end, ulist_sum_end.
        rewrite scalar_id, plus_rid.
        reflexivity.
    -   unfold linear_list_in; cbn.
        rewrite ulist_prop_add; cbn.
        split; [>|apply ulist_prop_end].
        exists [].
        split.
        +   rewrite list_image_end.
            cbn.
            reflexivity.
        +   reflexivity.
Qed.

Local Instance tensor_n_one : One (module_V tensor_n_algebra_module) := {
    one := to_tensor_n [1|tensor_n_one_in]
}.

Lemma tensor_n_list_in : ∀ l, subspace_set (tensor_n_subspace (list_size l))
    (list_prod (list_image vector_to_tensor l)).
Proof.
    intros l.
    cbn.
    apply linear_span_sub.
    exists l.
    split; reflexivity.
Qed.

Lemma to_tensor_n_list : ∀ l, to_tensor_n [_|tensor_n_list_in l] =
    list_prod (list_image vector_to_tensor_n l).
Proof.
    intros l.
    induction l.
    -   unfold list_image; cbn.
        rewrite list_prod_end.
        unfold one; cbn.
        apply f_equal.
        apply set_type_eq; reflexivity.
    -   unfold list_image; fold (list_image vector_to_tensor_n).
        rewrite list_prod_add.
        rewrite <- IHl.
        unfold vector_to_tensor_n.
        rewrite to_tensor_n_mult.
        apply f_equal.
        apply set_type_eq; reflexivity.
Qed.

Lemma tensor_n_base_in : ∀ {n} (x : set_type (tensor_n_base n)),
    subspace_set (tensor_n_subspace n) [x|].
Proof.
    intros n x.
    apply linear_span_sub.
    exact [|x].
Qed.

Theorem tensor_n_sum_grade : ∀ {n} x, of_grade n x →
    ∃ l : ulist (cring_U F * set_type (tensor_n_base n)),
        x = ulist_sum (ulist_image
        (λ p, fst p · to_tensor_n [_|tensor_n_base_in (snd p)]) l).
Proof.
    intros n x nx.
    destruct nx as [v x_eq]; subst x.
    change (single_to_grade_sum nat tensor_n_module v) with (to_tensor_n v).
    assert (linear_combination_of (tensor_n_base n) [v|]) as v_in.
    {
        rewrite <- (span_linear_combination U).
        exact [|v].
    }
    destruct v_in as [[l l_comb] [l_eq l_in]].
    assert (∃ l' : ulist (cring_U F * set_type (tensor_n_base n)),
        [v|] = ulist_sum (ulist_image (λ p, fst p · [snd p|]) l')) as [l' l'_eq].
    {
        rewrite l_eq.
        unfold linear_combination; cbn.
        unfold linear_list_in in l_in; cbn in l_in.
        clear l_comb l_eq.
        induction l using ulist_induction.
        -   exists ulist_end.
            do 2 rewrite ulist_image_end.
            reflexivity.
        -   rewrite ulist_prop_add in l_in.
            destruct l_in as [a_in l_in].
            specialize (IHl l_in) as [l' l'_eq].
            destruct a as [a al]; cbn in *.
            exists ((a, [_|a_in]) ː l').
            do 2 rewrite ulist_image_add, ulist_sum_add; cbn.
            rewrite l'_eq.
            reflexivity.
    }
    clear l l_comb l_eq l_in.
    assert (∀ x : set_type (tensor_n_base n), subspace_set (tensor_n_subspace n) [x|]) as x_in.
    {
        intros x.
        cbn.
        apply linear_span_sub.
        exact [|x].
    }
    pose (x_transfer (x : set_type (tensor_n_base n))
        := [_|x_in x] : module_V (tensor_n_module n)).
    pose (l := ulist_image (λ x, fst x · x_transfer (snd x)) l').
    assert (v = ulist_sum l) as u_eq.
    {
        unfold l.
        apply set_type_eq.
        rewrite l'_eq.
        clear l.
        unfold x_transfer.
        clear x_transfer.
        clear l'_eq.
        induction l' using ulist_induction.
        -   do 2 rewrite ulist_image_end, ulist_sum_end.
            reflexivity.
        -   do 2 rewrite ulist_image_add, ulist_sum_add.
            unfold plus at 2; cbn.
            rewrite IHl'.
            apply rplus.
            unfold scalar_mult at 2; cbn.
            reflexivity.
    }
    subst v.
    exists l'.
    unfold l.
    clear l l'_eq.
    induction l' as [|a l] using ulist_induction.
    {
        do 2 rewrite ulist_image_end, ulist_sum_end.
        apply single_to_grade_sum_zero.
    }
    do 2 rewrite ulist_image_add, ulist_sum_add.
    rewrite to_tensor_n_plus.
    rewrite IHl.
    apply rplus.
    clear l IHl.
    destruct a as [a v]; cbn.
    rewrite to_tensor_n_scalar.
    apply f_equal.
    unfold x_transfer.
    apply f_equal.
    apply set_type_eq; reflexivity.
Qed.

Theorem tensor_n_sum : ∀ x, ∃ l : ulist (U * list (module_V V)),
    x = ulist_sum (ulist_image (λ p, fst p · list_prod
        (list_image vector_to_tensor_n (snd p))) l).
Proof.
    intros x.
    induction x as [|u v i iu iv IHx] using grade_induction.
    {
        exists ulist_end.
        rewrite ulist_image_end, ulist_sum_end.
        reflexivity.
    }
    destruct IHx as [vl v_eq].
    assert (∃ ul : ulist (U * list (module_V V)),
        u = ulist_sum (ulist_image (λ p, fst p · list_prod
            (list_image vector_to_tensor_n (snd p))) ul)) as [ul u_eq].
    {
        clear v iv vl v_eq.
        pose proof (tensor_n_sum_grade _ iu) as [l l_eq].
        subst u.
        clear iu.
        exists (ulist_image (λ x, (fst x, ex_val [|snd x])) l).
        rewrite ulist_image_comp; cbn.
        apply f_equal.
        apply f_equal2; [>|reflexivity].
        apply functional_ext.
        intros [a v]; cbn.
        apply f_equal.
        rewrite <- to_tensor_n_list.
        clear l.
        rewrite_ex_val l [v_eq v_size].
        subst i.
        apply to_tensor_n_eq.
        exact v_eq.
    }
    exists (ul + vl).
    subst u v.
    rewrite ulist_image_conc, ulist_sum_plus.
    reflexivity.
Qed.

Local Instance tensor_n_mult_lid : MultLid (module_V tensor_n_algebra_module).
Proof.
    split.
    intros a.
    pose proof (tensor_n_sum a) as [l a_eq]; subst a.
    induction l as [|[a l] l'] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        apply mult_ranni.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite ldist.
    rewrite IHl'.
    apply rplus.
    clear IHl' l'.
    rewrite scalar_rmult.
    apply f_equal.
    rewrite <- to_tensor_n_list.
    unfold one; cbn.
    rewrite to_tensor_n_mult.
    apply f_equal.
    apply set_type_eq; cbn.
    apply mult_lid.
Qed.

Local Instance tensor_n_mult_rid : MultRid (module_V tensor_n_algebra_module).
Proof.
    split.
    intros a.
    pose proof (tensor_n_sum a) as [l a_eq]; subst a.
    induction l as [|[a l] l'] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        apply mult_lanni.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite rdist.
    rewrite IHl'.
    apply rplus.
    clear IHl' l'.
    rewrite scalar_lmult.
    apply f_equal.
    rewrite <- to_tensor_n_list.
    unfold one; cbn.
    rewrite to_tensor_n_mult.
    pose proof (plus_rid (list_size l)) as eq.
    rewrite (to_tensor_n_k_eq eq).
    apply f_equal.
    apply set_type_eq; cbn.
    destruct eq; cbn.
    apply mult_rid.
Qed.

Local Instance tensor_n_mult_assoc
    : MultAssoc (module_V tensor_n_algebra_module).
Proof.
    split.
    intros a b c.
    pose proof (tensor_n_sum a) as [l a_eq]; subst a.
    induction l as [|[α a] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 3 rewrite mult_lanni.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    change (grade_sum_type nat tensor_n_module) with (module_V (tensor_n_algebra_module)).
    do 3 rewrite rdist.
    rewrite IHl.
    apply rplus.
    clear l IHl.
    do 3 rewrite scalar_lmult.
    apply f_equal; clear α.
    pose proof (tensor_n_sum b) as [l b_eq]; subst b.
    induction l as [|[α b] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite mult_lanni.
        rewrite mult_ranni.
        rewrite mult_lanni.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    change (grade_sum_type nat tensor_n_module) with (module_V (tensor_n_algebra_module)).
    rewrite rdist.
    do 2 rewrite ldist.
    rewrite rdist.
    rewrite IHl.
    apply rplus.
    clear l IHl.
    rewrite scalar_lmult.
    do 2 rewrite scalar_rmult.
    rewrite scalar_lmult.
    apply f_equal; clear α.
    pose proof (tensor_n_sum c) as [l c_eq]; subst c.
    induction l as [|[α c] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 3 rewrite mult_ranni.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    change (grade_sum_type nat tensor_n_module) with (module_V (tensor_n_algebra_module)).
    do 3 rewrite ldist.
    rewrite IHl.
    apply rplus.
    clear l IHl.
    do 3 rewrite scalar_rmult.
    apply f_equal; clear α.
    do 3 rewrite <- to_tensor_n_list.
    do 4 rewrite to_tensor_n_mult.
    pose proof (plus_assoc (list_size a) (list_size b) (list_size c)) as eq.
    rewrite (to_tensor_n_k_eq eq).
    apply f_equal.
    apply set_type_eq; cbn.
    destruct eq; cbn.
    apply mult_assoc.
Qed.

Definition tensor_algebra_n := make_algebra
    F
    tensor_n_algebra_module
    tensor_n_mult
    tensor_n_mult_ldist
    tensor_n_mult_rdist
    tensor_n_mult_assoc
    tensor_n_one
    tensor_n_mult_lid
    tensor_n_mult_rid
    tensor_n_scalar_lmult
    tensor_n_scalar_rmult
.

End TensorAlgebraGrade.


Require Import ZArith.
Require Import String.

Require Export fun_domains.
Require Export fun_domains_aux.

Set Implicit Arguments.

Inductive kstep : kcfg -> kcfg -> Prop :=
 | k_cool_i : forall i e rest,
     kcell_step kstep (kra (KInt i) (kra (KFreeze e) rest))
                      (kra (cool_exp_kitem (ECon i) e) rest)
 | k_cool_b : forall b e rest,
     kcell_step kstep (kra (KBool b) (kra (KFreeze e) rest))
                      (kra (cool_exp_kitem (BCon b) e) rest)
 | k_heat_call : forall args v k f rest,
       first_unevaluated_arg nil args = Some (v, k) ->
       heat_step kstep (KExp (ECall f args)) v (KFreeze (KExp (ECall f k))) rest
 | k_heat_scall : forall args v k f rest,
       first_unevaluated_arg nil args = Some (v, k) ->
       heat_step kstep (KStmt (SCall f args)) v (KFreeze (KStmt (SCall f k))) rest
 | k_next_defn : forall Args Body F P WildVar1 WildVar2, krule kstep [k_cell (write (kra (KPgm (cons (FunDef F Args Body) P)) WildVar1) (kra (KPgm P) WildVar1)); fun_cell (write WildVar2 (kra (KId F) kdot |-> kra (KDefn (FunDef F Args Body)) kdot :* WildVar2))]
 | k_plus : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (EPlus (ECon I) (ECon J))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KInt (Zplus I J)) WildVar1))]
 | k_mult : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (EMult (ECon I) (ECon J))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KInt (Zmult I J)) WildVar1))]
 | k_minus : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (EMinus (ECon I) (ECon J))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KInt (Zminus I J)) WildVar1))]
 | k_neg : forall I WildVar1 x1, eq (ExpFromK x1) (Some (ENeg (ECon I))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KInt (Zopp I)) WildVar1))]
 | k_div : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (EDiv (ECon I) (ECon J))) -> eq (Zneq_bool 0 J) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KInt (Zdiv I J)) WildVar1))]
 | k_le : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (BLe (ECon I) (ECon J))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KBool (Zle_bool I J)) WildVar1))]
 | k_lt : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (BLt (ECon I) (ECon J))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KBool (Zlt_bool I J)) WildVar1))]
 | k_eq : forall I J WildVar1 x1, eq (ExpFromK x1) (Some (BEq (ECon I) (ECon J))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KBool (Z.eqb I J)) WildVar1))]
 | k_not : forall B WildVar1 x1, eq (ExpFromK x1) (Some (BNot (BCon B))) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KBool (negb B)) WildVar1))]
 | k_and_t : forall B WildVar1 x1, eq (ExpFromK x1) (Some (BAnd (BCon true) B)) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK B) WildVar1))]
 | k_and_f : forall WildVar1 WildVar2 x1, eq (ExpFromK x1) (Some (BAnd (BCon false) WildVar1)) -> krule kstep [k_cell (write (kra x1 WildVar2) (kra (KBool false) WildVar2))]
 | k_or_t : forall WildVar1 WildVar2 x1, eq (ExpFromK x1) (Some (BOr (BCon true) WildVar1)) -> krule kstep [k_cell (write (kra x1 WildVar2) (kra (KBool true) WildVar2))]
 | k_or_f : forall B WildVar1 x1, eq (ExpFromK x1) (Some (BOr (BCon false) B)) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK B) WildVar1))]
 | k_skip : forall WildVar1, krule kstep [k_cell (write (kra (KStmt Skip) WildVar1) WildVar1)]
 | k_if_t : forall S WildVar1 WildVar2, krule kstep [k_cell (write (kra (KStmt (SIf (BCon true) S WildVar1)) WildVar2) (kra (KStmt S) WildVar2))]
 | k_if_f : forall S WildVar1 WildVar2, krule kstep [k_cell (write (kra (KStmt (SIf (BCon false) WildVar1 S)) WildVar2) (kra (KStmt S) WildVar2))]
 | k_while : forall B S WildVar1, krule kstep [k_cell (write (kra (KStmt (SWhile B S)) WildVar1) (kra (KStmt (SIf B (Seq S (SWhile B S)) Skip)) WildVar1))]
 | k_lookup : forall I V WildVar1 WildVar2 x1 x2, MapEquiv x1 (kra (KId I) kdot |-> kra x2 kdot :* WildVar1) -> eq (KResultFromK x2) (Some V) -> krule kstep [k_cell (write (kra (KId I) WildVar2) (kra (KResultToK V) WildVar2)); env_cell (write x1 (kra (KId I) kdot |-> kra (KResultToK V) kdot :* WildVar1))]
 | k_load : forall Addr V WildVar1 WildVar2 x1 x2 x3, eq (ExpFromK x1) (Some (ELoad (ECon Addr))) -> MapEquiv x2 (kra (KInt Addr) kdot |-> kra x3 kdot :* WildVar2) -> eq (KResultFromK x3) (Some V) -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (KResultToK V) WildVar1)); heap_cell (write x2 (kra (KInt Addr) kdot |-> kra (KResultToK V) kdot :* WildVar2))]
 | k_assign : forall V WildVar1 WildVar2 WildVar3 X x1 x2, eq (KResultFromExp x1) (Some V) -> MapEquiv x2 (kra (KId X) kdot |-> WildVar1 :* WildVar3) -> krule kstep [k_cell (write (kra (KStmt (SAssign X x1)) WildVar2) WildVar2); env_cell (write x2 (kra (KId X) kdot |-> kra (KResultToK V) kdot :* WildVar3))]
 | k_hassign : forall Addr V WildVar1 WildVar2 WildVar3 x1 x2, eq (KResultFromExp x1) (Some V) -> MapEquiv x2 (kra (KInt Addr) kdot |-> WildVar1 :* WildVar3) -> krule kstep [k_cell (write (kra (KStmt (HAssign (ECon Addr) x1)) WildVar2) WildVar2); heap_cell (write x2 (kra (KInt Addr) kdot |-> kra (KResultToK V) kdot :* WildVar3))]
 | k_decl : forall WildVar1 WildVar2 X, krule kstep [k_cell (write (kra (KStmt (Decl X)) WildVar1) WildVar1); env_cell (write WildVar2 (kra (KId X) kdot |-> kra (KUndef undef) kdot :* WildVar2))]
 | k_call : forall Args Body Env F Formals Rest Stk WildVar1 x1 x2, eq (ExpFromK x1) (Some (ECall F Args)) -> MapEquiv x2 (kra (KId F) kdot |-> kra (KDefn (FunDef F Formals Body)) kdot :* WildVar1) -> eq (all_values Args) true -> krule kstep [k_cell (write (kra x1 Rest) (kra (KStmt Body) kdot)); fun_cell (write x2 (kra (KId F) kdot |-> kra (KDefn (FunDef F Formals Body)) kdot :* WildVar1)); env_cell (write Env (mkMap Formals Args)); stk_cell (write Stk (cons (frame Rest Env) Stk))]
 | k_scall : forall Args Body Env F Formals Rest Stk WildVar1 x1, MapEquiv x1 (kra (KId F) kdot |-> kra (KDefn (FunDef F Formals Body)) kdot :* WildVar1) -> eq (all_values Args) true -> krule kstep [k_cell (write (kra (KStmt (SCall F Args)) Rest) (kra (KStmt Body) kdot)); fun_cell (write x1 (kra (KId F) kdot |-> kra (KDefn (FunDef F Formals Body)) kdot :* WildVar1)); env_cell (write Env (mkMap Formals Args)); stk_cell (write Stk (cons (frame Rest Env) Stk))]
 | k_return : forall Env Rest Stk V WildVar1 WildVar2 x1, eq (KResultFromExp x1) (Some V) -> krule kstep [k_cell (write (kra (KStmt (SReturn x1)) WildVar1) (kra (KResultToK V) Rest)); env_cell (write WildVar2 Env); stk_cell (write (cons (frame Rest Env) Stk) Stk)]
 | k_returnv : forall Env Rest Stk WildVar1 WildVar2, krule kstep [k_cell (write (kra (KStmt SReturnVoid) WildVar1) Rest); env_cell (write WildVar2 Env); stk_cell (write (cons (frame Rest Env) Stk) Stk)]
 | k_heat_load : forall E WildVar1 x1, eq (ExpFromK x1) (Some (ELoad E)) -> eq (notKResult (kra (ExpToK E) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK E) (kra (KFreeze (ExpToK (ELoad HOLE_Exp))) WildVar1)))]
 | k_heat_plus_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EPlus X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (EPlus HOLE_Exp Y))) WildVar1)))]
 | k_heat_plus_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EPlus X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (EPlus X HOLE_Exp))) WildVar1)))]
 | k_heat_minus_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EMinus X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (EMinus HOLE_Exp Y))) WildVar1)))]
 | k_heat_minus_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EMinus X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (EMinus X HOLE_Exp))) WildVar1)))]
 | k_heat_neg : forall WildVar1 X x1, eq (ExpFromK x1) (Some (ENeg X)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (ENeg HOLE_Exp))) WildVar1)))]
 | k_heat_mult_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EMult X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (EMult HOLE_Exp Y))) WildVar1)))]
 | k_heat_mult_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EMult X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (EMult X HOLE_Exp))) WildVar1)))]
 | k_heat_div_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EDiv X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (EDiv HOLE_Exp Y))) WildVar1)))]
 | k_heat_div_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (EDiv X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (EDiv X HOLE_Exp))) WildVar1)))]
 | k_heat_le_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (BLe X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (BLe HOLE_Exp Y))) WildVar1)))]
 | k_heat_le_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (BLe X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (BLe X HOLE_Exp))) WildVar1)))]
 | k_heat_lt_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (BLt X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (BLt HOLE_Exp Y))) WildVar1)))]
 | k_heat_lt_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (BLt X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (BLt X HOLE_Exp))) WildVar1)))]
 | k_heat_eq_l : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (BEq X Y)) -> eq (notKResult (kra (ExpToK X) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK X) (kra (KFreeze (ExpToK (BEq HOLE_Exp Y))) WildVar1)))]
 | k_heat_eq_r : forall WildVar1 X Y x1, eq (ExpFromK x1) (Some (BEq X Y)) -> eq (notKResult (kra (ExpToK Y) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK Y) (kra (KFreeze (ExpToK (BEq X HOLE_Exp))) WildVar1)))]
 | k_heat_not : forall B WildVar1 x1, eq (ExpFromK x1) (Some (BNot B)) -> eq (notKResult (kra (ExpToK B) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK B) (kra (KFreeze (ExpToK (BNot HOLE_Exp))) WildVar1)))]
 | k_heat_and : forall B C WildVar1 x1, eq (ExpFromK x1) (Some (BAnd B C)) -> eq (notKResult (kra (ExpToK B) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK B) (kra (KFreeze (ExpToK (BAnd HOLE_Exp C))) WildVar1)))]
 | k_heat_or : forall B C WildVar1 x1, eq (ExpFromK x1) (Some (BOr B C)) -> eq (notKResult (kra (ExpToK B) kdot)) true -> krule kstep [k_cell (write (kra x1 WildVar1) (kra (ExpToK B) (kra (KFreeze (ExpToK (BOr HOLE_Exp C))) WildVar1)))]
 | k_heat_assign : forall E V WildVar1, eq (notKResult (kra (ExpToK E) kdot)) true -> krule kstep [k_cell (write (kra (KStmt (SAssign V E)) WildVar1) (kra (ExpToK E) (kra (KFreeze (KStmt (SAssign V HOLE_Exp))) WildVar1)))]
 | k_heat_hassign_l : forall E1 E2 WildVar1, eq (notKResult (kra (ExpToK E1) kdot)) true -> krule kstep [k_cell (write (kra (KStmt (HAssign E1 E2)) WildVar1) (kra (ExpToK E1) (kra (KFreeze (KStmt (HAssign HOLE_Exp E2))) WildVar1)))]
 | k_heat_hassign_r : forall E1 E2 WildVar1, eq (notKResult (kra (ExpToK E2) kdot)) true -> krule kstep [k_cell (write (kra (KStmt (HAssign E1 E2)) WildVar1) (kra (ExpToK E2) (kra (KFreeze (KStmt (HAssign E1 HOLE_Exp))) WildVar1)))]
 | k_heat_if : forall B S1 S2 WildVar1, eq (notKResult (kra (ExpToK B) kdot)) true -> krule kstep [k_cell (write (kra (KStmt (SIf B S1 S2)) WildVar1) (kra (ExpToK B) (kra (KFreeze (KStmt (SIf HOLE_Exp S1 S2))) WildVar1)))]
 | k_heat_return : forall E WildVar1, eq (notKResult (kra (ExpToK E) kdot)) true -> krule kstep [k_cell (write (kra (KStmt (SReturn E)) WildVar1) (kra (ExpToK E) (kra (KFreeze (KStmt (SReturn HOLE_Exp))) WildVar1)))]
 | k_heat_seq : forall S1 S2 WildVar1, krule kstep [k_cell (write (kra (KStmt (Seq S1 S2)) WildVar1) (kra (KStmt S1) (kra (KStmt S2) WildVar1)))]
.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Diffie-Hellman definitions. *)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.RndNat.
Require Export FCF.GroupTheory.

Local Open Scope group_scope.

Section DDH.

  Section DDH_Concrete.

    Context`{FCG : FiniteCyclicGroup}.
    Variable A : (GroupElement * GroupElement * GroupElement) -> Comp bool.

    Definition DDH0 :=
      x <-$ [0 .. order);
      y <-$ [0 .. order);
      b <-$ (A (g^x, g^y, g^(x * y)));
      ret b.

    Definition DDH1  :=
      x <-$ [0 .. order);
      y <-$ [0 .. order);
      z <-$ [0 .. order);
      b <-$ (A (g^x, g^y, g^z));
      ret b.

    Definition DDH_Advantage:= | Pr[DDH0] - Pr[DDH1] |.

  End DDH_Concrete.

End DDH.


Require Import Coq.ZArith.ZArith.
Require Import Lia.
Open Scope Z_scope.

Lemma coin_3_5 : forall n : Z, n >= 8 -> exists (x y : Z), 3 * x + 5 * y = n.
Proof.
  destruct n; try lia.
  induction p; intros.
  repeat rewrite Pos2Z.inj_xI in *.
  assert (Ht2 : Z.pos p = 4 \/ Z.pos p = 5 \/
                Z.pos p = 6 \/ Z.pos p = 7 \/
                Z.pos p >= 8) by lia.
  destruct Ht2 as [Ht2 | [Ht2 | [Ht2 | [Ht2 | Ht2]]]].
  rewrite Ht2. exists (-2), 3. lia.
  rewrite Ht2. exists (-3), 4. lia.
  rewrite Ht2. exists (-4), 5. lia.
  rewrite Ht2. exists (-5), 6. lia.
  apply IHp in Ht2.
  destruct Ht2 as [x [y Ht]].
  exists (2 * x - 3), (2 * y + 2). lia.

  rewrite Pos2Z.pos_xO in *.
  assert (Ht2 : Z.pos p = 4 \/ Z.pos p = 5 \/
                Z.pos p = 6 \/ Z.pos p = 7 \/
                Z.pos p >= 8) by lia.
  destruct Ht2 as [Ht2 | [Ht2 | [Ht2 | [Ht2 | Ht2]]]].
  rewrite Ht2. exists 1, 1. lia.
  rewrite Ht2. exists 0, 2. lia.
  rewrite Ht2. exists 4, 0. lia.
  rewrite Ht2. exists 3, 1. lia.
  apply IHp in Ht2.
  destruct Ht2 as [x [y Ht]].
  exists (2 * x), (2 * y). lia.

  (* impossible case *)
  lia.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_conga :
	forall A B C a b c U V u v,
	OnRay B A U ->
	OnRay B C V ->
	OnRay b a u ->
	OnRay b c v ->
	Cong B U b u ->
	Cong B V b v ->
	Cong U V u v ->
	nCol A B C ->
	CongA A B C a b c.
Proof.
	intros A B C a b c U V u v.
	intros OnRay_BA_U.
	intros OnRay_BC_V.
	intros OnRay_ba_u.
	intros OnRay_bc_v.
	intros Cong_BU_bu.
	intros Cong_BV_bv.
	intros Cong_UV_uv.
	intros nCol_A_B_C.

	unfold CongA.
	exists U, V, u, v.
	split.
	exact OnRay_BA_U.
	split.
	exact OnRay_BC_V.
	split.
	exact OnRay_ba_u.
	split.
	exact OnRay_bc_v.
	split.
	exact Cong_BU_bu.
	split.
	exact Cong_BV_bv.
	split.
	exact Cong_UV_uv.
	exact nCol_A_B_C.
Qed.

End Euclid.


(** The following axiom systems are used to formalize
    Euclid's proofs of Euclid's Elements.OriginalProofs.statements. *)

(** First, we define an axiom system for neutral geometry,
    i.e. geometry without continuity axioms nor parallel postulate.
 *)

Variable Point: Type.
Variable Circle: Type.
Variable Cong : Point -> Point -> Point -> Point -> Prop.
Variable  BetS : Point -> Point -> Point -> Prop.
Variable  PA : Point.
Variable  PB : Point.
Variable  PC : Point.
Variable  CI : Circle -> Point -> Point -> Point -> Prop.
Definition eq := @eq Point.
Definition neq A B := ~ eq A B.
Definition  TE A B C := ~ (neq A B /\ neq B C /\ ~ BetS A B C).
Definition  nCol A B C := neq A B /\ neq A C /\ neq B C /\ ~ BetS A B C /\ ~ BetS A C B /\ ~ BetS B A C.
Definition  Col A B C := (eq A B \/ eq A C \/ eq B C \/ BetS B A C \/ BetS A B C \/ BetS A C B).
Definition  Cong_3 A B C a b c := Cong A B a b /\ Cong B C b c /\ Cong A C a c.
Definition  TS P A B Q := exists X, BetS P X Q /\ Col A B X /\ nCol A B P.
Definition  Triangle A B C := nCol A B C.

Definition  OnCirc B J := exists X Y U, CI J U X Y /\ Cong U B X Y.
Definition  InCirc P J := exists X Y U V W, CI J U V W /\ (eq P U \/ (BetS U Y X /\ Cong U X V W /\ Cong U P U Y)).
Definition  OutCirc P J := exists X U V W, CI J U V W /\ BetS U X P /\ Cong U X V W.

Axiom  cn_congruencetransitive :
   forall B C D E P Q, Cong P Q B C -> Cong P Q D E -> Cong B C D E.
Axiom  cn_congruencereflexive :
   forall A B, Cong A B A B.
Axiom  cn_equalityreverse :
   forall A B, Cong A B B A.
Axiom  cn_sumofparts :
   forall A B C a b c, Cong A B a b -> Cong B C b c -> BetS A B C -> BetS a b c -> Cong A C a c.
Axiom  cn_stability :
   forall A B, ~ neq A B -> eq A B.
Axiom  axiom_circle_center_radius :
   forall A B C J P, CI J A B C -> OnCirc P J -> Cong A P B C.
Axiom  axiom_lower_dim : nCol PA PB PC.
Axiom  axiom_betweennessidentity :
   forall A B, ~ BetS A B A.
Axiom  axiom_betweennesssymmetry :
   forall A B C, BetS A B C -> BetS C B A.
Axiom  axiom_innertransitivity :
   forall A B C D,
    BetS A B D -> BetS B C D -> BetS A B C.
Axiom  axiom_connectivity :
   forall A B C D,
    BetS A B D -> BetS A C D -> ~ BetS A B C -> ~ BetS A C B ->
    eq B C.
Axiom  axiom_nocollapse :
   forall A B C D, neq A B -> Cong A B C D -> neq C D.
Axiom  axiom_5_line :
   forall A B C D a b c d,
    Cong B C b c -> Cong A D a d -> Cong B D b d ->
    BetS A B C -> BetS a b c -> Cong A B a b ->
    Cong D C d c.

Axiom   postulate_Pasch_inner :
   forall A B C P Q,
    BetS A P C -> BetS B Q C -> nCol A C B ->
    exists X, BetS A X Q /\ BetS B X P.
Axiom   postulate_Pasch_outer :
   forall A B C P Q,
    BetS A P C -> BetS B C Q -> nCol B Q A ->
    exists X, BetS A X Q /\ BetS B P X.
Axiom   postulate_Euclid2 : forall A B, neq A B -> exists X, BetS A B X.
Axiom   postulate_Euclid3 : forall A B, neq A B -> exists X, CI X A A B.

(** Second, we enrich the axiom system with line-circle
     and circle-circle continuity axioms.
    Those two axioms state that we allow ruler and compass
    constructions.
*)

Axiom   postulate_line_circle :
   forall A B C K P Q,
    CI K C P Q -> InCirc B K -> neq A B ->
    exists X Y, Col A B X /\ BetS A B Y /\ OnCirc X K /\ OnCirc Y K /\ BetS X B Y.
Axiom   postulate_circle_circle :
   forall C D F G J K P Q R S,
    CI J C R S -> InCirc P J ->
    OutCirc Q J -> CI K D F G ->
    OnCirc P K -> OnCirc Q K ->
    exists X, OnCirc X J /\ OnCirc X K.

(** Third, we introduce the famous fifth postulate of Euclid,
    which ensures that the geometry is
    Euclidean (i.e. not hyperbolic).
 *)

Axiom   postulate_Euclid5 :
   forall a p q r s t,
    BetS r t s -> BetS p t q -> BetS r a q ->
    Cong p t q t -> Cong t r t s -> nCol p q s ->
    exists X, BetS p a X /\ BetS s q X.

(** Last, we enrich the axiom system with axioms for equality of areas. *)

Variable  EF : Point -> Point -> Point -> Point -> Point -> Point -> Point -> Point -> Prop.
Variable  ET : Point -> Point -> Point -> Point -> Point -> Point -> Prop.
Axiom   axiom_congruentequal :
   forall A B C a b c, Cong_3 A B C a b c -> ET A B C a b c.
Axiom   axiom_ETpermutation :
   forall A B C a b c,
    ET A B C a b c ->
    ET A B C b c a /\
    ET A B C a c b /\
    ET A B C b a c /\
    ET A B C c b a /\
    ET A B C c a b.
Axiom   axiom_ETsymmetric :
   forall A B C a b c, ET A B C a b c -> ET a b c A B C.
Axiom   axiom_EFpermutation :
   forall A B C D a b c d,
   EF A B C D a b c d ->
     EF A B C D b c d a /\
     EF A B C D d c b a /\
     EF A B C D c d a b /\
     EF A B C D b a d c /\
     EF A B C D d a b c /\
     EF A B C D c b a d /\
     EF A B C D a d c b.
Axiom   axiom_halvesofequals :
   forall A B C D a b c d, ET A B C B C D ->
                           TS A B C D -> ET a b c b c d ->
                           TS a b c d -> EF A B D C a b d c -> ET A B C a b c.
Axiom   axiom_EFsymmetric :
   forall A B C D a b c d, EF A B C D a b c d ->
                           EF a b c d A B C D.
Axiom   axiom_EFtransitive :
   forall A B C D P Q R S a b c d,
     EF A B C D a b c d -> EF a b c d P Q R S ->
     EF A B C D P Q R S.
Axiom   axiom_ETtransitive :
   forall A B C P Q R a b c,
    ET A B C a b c -> ET a b c P Q R -> ET A B C P Q R.
Axiom   axiom_cutoff1 :
   forall A B C D E a b c d e,
    BetS A B C -> BetS a b c -> BetS E D C -> BetS e d c ->
    ET B C D b c d -> ET A C E a c e ->
    EF A B D E a b d e.
Axiom   axiom_cutoff2 :
   forall A B C D E a b c d e,
    BetS B C D -> BetS b c d -> ET C D E c d e -> EF A B D E a b d e ->
    EF A B C E a b c e.
Axiom   axiom_paste1 :
   forall A B C D E a b c d e,
    BetS A B C -> BetS a b c -> BetS E D C -> BetS e d c ->
    ET B C D b c d -> EF A B D E a b d e ->
    ET A C E a c e.
Axiom   axiom_deZolt1 :
   forall B C D E, BetS B E D -> ~ ET D B C E B C.
Axiom   axiom_deZolt2 :
   forall A B C E F,
    Triangle A B C -> BetS B E A -> BetS B F C ->
  ~ ET A B C E B F.
Axiom   axiom_paste2 :
   forall A B C D E M a b c d e m,
    BetS B C D -> BetS b c d -> ET C D E c d e ->
    EF A B C E a b c e ->
    BetS A M D -> BetS B M E ->
    BetS a m d -> BetS b m e ->
    EF A B D E a b d e.
Axiom   axiom_paste3 :
   forall A B C D M a b c d m,
    ET A B C a b c -> ET A B D a b d ->
    BetS C M D ->
    (BetS A M B \/ eq A M \/ eq M B) ->
    BetS c m d ->
    (BetS a m b \/ eq a m \/ eq m b) ->
    EF A C B D a c b d.
Axiom   axiom_paste4 :
   forall A B C D F G H J K L M P e m,
    EF A B m D F K H G -> EF D B e C G H M L ->
    BetS A P C -> BetS B P D -> BetS K H M -> BetS F G L ->
    BetS B m D -> BetS B e C -> BetS F J M -> BetS K J L ->
    EF A B C D F K M L.


Require Import Rbase Ranalysis.
Require Import Rinterval Rfunctions Rfunction_def.
Require Import Ranalysis_def Rfunction_facts.
Require Import MyRIneq MyR_dist Lra.

Require Import Ass_handling.

Local Open Scope R_scope.

(** * Example of dense domains *)

(* TODO: move this 3 lemmas *)

Lemma middle_r_in_Rball : forall c r, 0 < r -> Rball c r (middle c (c + r)).
Proof.
intros c r r_pos ; apply included_open_interval_Rball2 ; split.
 transitivity c.
  lra.
  apply middle_is_in_the_middle ; lra.
 apply middle_is_in_the_middle ; lra.
Qed.

Lemma middle_l_in_Rball : forall c r, 0 < r -> Rball c r (middle (c - r) c).
Proof.
intros c r r_pos ; apply included_open_interval_Rball2 ; split.
 apply middle_is_in_the_middle ; lra.
 transitivity c.
  apply middle_is_in_the_middle ; lra.
  lra.
Qed.

Lemma Rlt_div_2 : forall x, 0 < x -> x / 2 < x.
Proof.
intros ; lra.
Qed.

Lemma dense_interval: forall lb ub x, lb < ub ->
  interval lb ub x -> dense (interval lb ub) x.
Proof.
intros lb ub x Hlt [xlb xub] eps eps_pos ; destruct xlb as [xlb | xeq].
 destruct xub as [xub | xeq].
  pose (h := Rmin (eps / 2) (interval_dist lb ub x)) ;
  assert (h_pos : 0 < h).
   apply Rmin_pos_lt, open_interval_dist_pos ;
   [lra | split ; assumption].
  exists (x + h) ; split.
   split.
    apply interval_dist_bound ; [split ; left ; assumption |].
    rewrite Rabs_right ; [apply Rmin_r | left ; assumption].
    apply Rplus_pos_neq ; assumption.
   rewrite R_dist_Rplus_compat, Rabs_right ; [| left ; assumption].
    apply Rle_lt_trans with (eps / 2) ; [apply Rmin_l | lra].
  pose (h := Rmin (eps / 2) (ub - lb)) ;
  assert (h_pos : 0 < h) by (apply Rmin_pos_lt ; lra).
   exists (x - h) ; split. split. split.
    transitivity (x - (ub - lb)).
     right ; subst ; ring.
     apply Rplus_le_compat_l, Ropp_le_contravar, Rmin_r.
     left ; subst ; apply Rminus_pos_lt ; assumption.
     subst ; apply Rgt_not_eq, Rminus_pos_lt ; assumption.
     rewrite R_dist_Rminus_compat, Rabs_right ; [| left ; assumption].
     apply Rle_lt_trans with (eps / 2) ; [apply Rmin_l | lra].
  pose (h := Rmin (eps / 2) (ub - lb)) ;
  assert (h_pos : 0 < h) by (apply Rmin_pos_lt ; lra).
   exists (x + h) ; split. split. split.
    left ; rewrite xeq ; apply Rplus_pos_lt ; assumption.
    transitivity (x + (ub - lb)) ; [| right ; rewrite xeq ; ring].
     apply Rplus_le_compat_l, Rmin_r.
     apply Rlt_not_eq, Rplus_pos_lt ; assumption.
     rewrite R_dist_Rplus_compat, Rabs_right ; [| left ; assumption].
     apply Rle_lt_trans with (eps / 2) ; [apply Rmin_l | lra].
Qed.

Lemma dense_open_interval: forall lb ub x, lb < ub ->
  interval lb ub x -> dense (open_interval lb ub) x.
Proof.
intros lb ub x Hlt [xlb xub] eps eps_pos ; assert (lbub : 0 < ub - lb) by lra.
destruct xlb as [xlb | xeq].
 destruct xub as [xub | xeq].
  assert (d_pos : 0 < interval_dist lb ub x / 2).
   apply Rlt_mult_inv_pos ; [apply open_interval_dist_pos | lra].
   split ; assumption.
  pose (h := Rmin (eps / 2) (interval_dist lb ub x / 2)) ;
  assert (h_pos : 0 < h) by (apply Rmin_pos_lt ; lra).
  exists (x + h) ; split.
   split.
    apply open_interval_dist_bound ; [split ; left ; assumption |].
    apply Rle_lt_trans with (interval_dist lb ub x / 2).
    rewrite Rabs_right ; [apply Rmin_r | left ; assumption].
    lra.
    apply Rplus_pos_neq ; assumption.
   rewrite R_dist_Rplus_compat, Rabs_right ; [| left ; assumption].
    apply Rle_lt_trans with (eps / 2) ; [apply Rmin_l | lra].
  pose (h := Rmin (eps / 2) ((ub - lb) / 2)) ;
  assert (h_pos : 0 < h) by (apply Rmin_pos_lt ; [| apply Rlt_mult_inv_pos] ; lra).
   exists (x - h) ; repeat split.
    apply Rle_lt_trans with (x - (ub - lb)).
     right ; subst ; ring.
     apply Rplus_lt_compat_l, Ropp_lt_contravar.
     apply Rle_lt_trans with ((ub - lb) / 2) ; [apply Rmin_r | apply Rlt_div_2 ; assumption].
     subst ; apply Rminus_pos_lt ; assumption.
     subst ; apply Rgt_not_eq, Rminus_pos_lt ; assumption.
     rewrite R_dist_Rminus_compat, Rabs_right ; [| left ; assumption].
     apply Rle_lt_trans with (eps / 2) ; [apply Rmin_l | lra].
  pose (h := Rmin (eps / 2) ((ub - lb)/2)) ;
  assert (h_pos : 0 < h) by (apply Rmin_pos_lt ; [| apply Rlt_mult_inv_pos] ; lra).
   exists (x + h) ; repeat split.
    rewrite xeq ; apply Rplus_pos_lt ; assumption.
    apply Rlt_le_trans with (x + (ub - lb)) ; [| right ; rewrite xeq ; ring].
     apply Rplus_lt_compat_l, Rle_lt_trans with ((ub - lb)/2) ; [apply Rmin_r |].
     apply Rlt_div_2 ; assumption.
     apply Rlt_not_eq, Rplus_pos_lt ; assumption.
     rewrite R_dist_Rplus_compat, Rabs_right ; [| left ; assumption].
     apply Rle_lt_trans with (eps / 2) ; [apply Rmin_l | lra].
Qed.

Lemma dense_Rball : forall c r x, Rball c r x -> dense (Rball c r) x.
Proof.
intros c r x x_in eps eps_pos ;
 assert (r_pos : 0 < r) by (eapply Rball_radius_pos ; eassumption) ;
 assert (Hlbub : c - r < c + r) by lra ;
 assert (x_in' : interval (c - r) (c + r) x).
  apply open_interval_interval, included_Rball_open_interval ; assumption.
 destruct (dense_open_interval (c - r) (c + r) x Hlbub x_in' eps eps_pos) as [y [[y_in y_neq] Hy]] ;
 exists y ; repeat split ; [apply included_open_interval_Rball2 | |] ; assumption.
Qed.

(** * Extensionality of growth_rate *)

Lemma growth_rate_ext: forall f g x, f == g ->
  growth_rate f x == growth_rate g x.
Proof.
intros f g x Heq y ; unfold growth_rate ;
 do 2 rewrite Heq ; reflexivity.
Qed.

Lemma growth_rate_ext_strong: forall (D : R -> Prop) f g x, D x ->
  (forall x, D x -> f x = g x) ->
  forall y, D y -> growth_rate f x y = growth_rate g x y.
Proof.
intros D f g x Dx Heq y y_in ; unfold growth_rate ;
 do 2 (rewrite Heq ; [| assumption]) ; reflexivity.
Qed.

(** * growth_rate is compatible with common operations. *)

Lemma growth_rate_mult_real_fct_compat: forall f (l:R) x y, D_x no_cond x y ->
  growth_rate (mult_real_fct l f)%F x y = l * growth_rate f x y.
Proof.
intros f l x y Dxy ; unfold growth_rate, mult_real_fct ; field ;
 apply Rminus_eq_contra ; symmetry ; apply Dxy.
Qed.

Lemma growth_rate_scal_compat: forall f (l:R) x y, D_x no_cond x y ->
  growth_rate ((fun _ => l) * f)%F x y = l * growth_rate f x y.
Proof.
intros f l x y Dxy ; unfold growth_rate, mult_fct ; field ;
 apply Rminus_eq_contra ; symmetry ; apply Dxy.
Qed.

Lemma growth_rate_opp_compat: forall f x y, D_x no_cond x y ->
  growth_rate (- f)%F x y = - growth_rate f x y.
Proof.
intros f x y Dxy ; unfold growth_rate, opp_fct ; field ;
 apply Rminus_eq_contra ; symmetry ; apply Dxy.
Qed.

Lemma growth_rate_plus_compat: forall f g x y, D_x no_cond x y ->
  growth_rate (f + g)%F x y = growth_rate f x y + growth_rate g x y.
Proof.
intros f g x y Dxy ; unfold growth_rate, plus_fct ; field ;
 apply Rminus_eq_contra ; symmetry ; apply Dxy.
Qed.

Lemma growth_rate_minus_compat: forall f g x y, D_x no_cond x y ->
  growth_rate (f - g)%F x y = growth_rate f x y - growth_rate g x y.
Proof.
intros f g x y Dxy ; unfold growth_rate, minus_fct ; field ;
 apply Rminus_eq_contra ; symmetry ; apply Dxy.
Qed.

Lemma growth_rate_mult_decomp: forall f g x y, x <> y ->
  growth_rate (f * g)%F x y =
 (growth_rate f x y) * g x + f y * growth_rate g x y.
Proof.
intros f g x y Hneq ; unfold growth_rate, mult_fct ; field ;
 apply Rminus_eq_contra ; symmetry ; assumption.
Qed.

Lemma growth_rate_inv_decomp: forall f x y,
  x <> y -> f x <> 0 -> f y <> 0 ->
  growth_rate (/ f)%F x y =
  - ((growth_rate f x y) * / (f x * f y)).
Proof.
intros ; unfold growth_rate, inv_fct ; field ;
 repeat split ; [| | apply Rminus_eq_contra ; symmetry ] ;
 assumption.
Qed.

(** * All the definitions using _in are contravariant in their domain *)

Lemma D_x_covariant : forall D E x,
  included D E -> included (D_x D x) (D_x E x).
Proof.
intros D E x inc y [y_neq y_in] ; split ; [apply inc |] ; assumption.
Qed.

Lemma limit1_in_contravariant : forall D E f x l, included D E ->
  limit1_in f E x l -> limit1_in f D x l.
Proof.
intros D E f x l inc Hfxl eps eps_pos ;
 destruct (Hfxl _ eps_pos) as [alp [alp_pos Halp]] ; exists alp ; split.
  assumption.
  intros y [Dy y_bd] ; apply Halp ; split ; [apply inc |] ; assumption.
Qed.

Lemma continuity_pt_in_contravariant : forall D E f x, included D E ->
  continuity_pt_in E f x -> continuity_pt_in D f x.
Proof.
intros D E f x inc f_cont Dx ; apply limit1_in_contravariant with E.
 assumption.
 apply f_cont, inc ; assumption.
Qed.

Lemma continuity_in_contravariant : forall D E f, included D E ->
  continuity_in E f -> continuity_in D f.
Proof.
intros D E f inc f_cont x ;
 apply continuity_pt_in_contravariant with E, f_cont ; assumption.
Qed.

Lemma derivable_pt_lim_in_contravariant : forall D E f x l, included D E ->
  derivable_pt_lim_in E f x l -> derivable_pt_lim_in D f x l.
Proof.
intros D E f x l inc f_der ; apply limit1_in_contravariant with (D_x E x).
 apply D_x_covariant ; assumption.
 apply f_der.
Qed.

Lemma derivable_pt_in_contravariant : forall D E f x, included D E ->
  derivable_pt_in E f x -> derivable_pt_in D f x.
Proof.
intros D E f x inc [l Hl] ; exists l ;
 apply derivable_pt_lim_in_contravariant with E ; assumption.
Qed.

Lemma derivable_in_contravariant : forall D E f, included D E ->
  derivable_in E f -> derivable_in D f.
Proof.
intros D E f inc f_der x Dx ; apply derivable_pt_in_contravariant with E.
 assumption.
 apply f_der, inc ; assumption.
Qed.

Lemma injective_in_contravariant : forall D E f, included D E ->
  injective_in E f -> injective_in D f.
Proof.
intros D E f inc f_inj x y x_in y_in Hxy ; apply f_inj ; try apply inc ; assumption.
Qed.

Lemma surjective_in_contravariant : forall D E f, included D E ->
  surjective_in E f -> surjective_in D f.
Proof.
intros D E f inc f_surj y y_in ; apply f_surj ; try apply inc ; assumption.
Qed.

Lemma increasing_in_contravariant : forall D E f, included D E ->
  increasing_in E f -> increasing_in D f.
Proof.
intros D E f inc f_inc x y x_in y_in Hxy ; apply f_inc ; try apply inc ; assumption.
Qed.

Lemma decreasing_in_contravariant : forall D E f, included D E ->
  decreasing_in E f -> decreasing_in D f.
Proof.
intros D E f inc f_dec x y x_in y_in Hxy ; apply f_dec ; try apply inc ; assumption.
Qed.

Lemma monotonous_in_contravariant : forall D E f, included D E ->
  monotonous_in E f -> monotonous_in D f.
Proof.
intros D E f inc [f_dec | f_inc] ;
 [left ; eapply decreasing_in_contravariant |
 right ; eapply increasing_in_contravariant] ; eassumption.
Qed.

Lemma strictly_increasing_in_contravariant : forall D E f, included D E ->
  strictly_increasing_in E f -> strictly_increasing_in D f.
Proof.
intros D E f inc f_inc x y x_in y_in Hxy ; apply f_inc ; try apply inc ; assumption.
Qed.

Lemma strictly_decreasing_in_contravariant : forall D E f, included D E ->
  strictly_decreasing_in E f -> strictly_decreasing_in D f.
Proof.
intros D E f inc f_dec x y x_in y_in Hxy ; apply f_dec ; try apply inc ; assumption.
Qed.

Lemma strictly_monotonous_in_contravariant : forall D E f, included D E ->
  strictly_monotonous_in E f -> strictly_monotonous_in D f.
Proof.
intros D E f inc [f_dec | f_inc] ;
 [left ; eapply strictly_decreasing_in_contravariant |
 right ; eapply strictly_increasing_in_contravariant] ; eassumption.
Qed.

Definition reciprocal_in_contravariant : forall D E f g, included D E ->
  reciprocal_in E f g -> reciprocal_in D f g.
Proof.
intros D E f g inc Hfg x x_in ; apply Hfg, inc ; assumption.
Qed.

(** * Extensionality of limit1_in *)

Lemma limit1_in_ext: forall (D : R -> Prop) f g x l,
  (forall x, D x -> f x = g x) ->
  limit1_in f D l x -> limit1_in g D l x.
Proof.
intros D f g x l Heq Hf eps eps_pos ;
 destruct (Hf _ eps_pos) as [alp [alp_pos Halp]] ;
 exists alp ; split ; [assumption |].
 intros y Hy ; rewrite <- Heq ; [apply Halp |] ; apply Hy.
Qed.

Lemma limit1_in_ext_strong: forall (D : R -> Prop) r f g x l, 0 < r ->
  (forall y, Rball x r y -> D y -> f y = g y) ->
  limit1_in f D l x -> limit1_in g D l x.
Proof.
intros D alp f g x l alp_pos Heq Hf eps eps_pos ;
 destruct (Hf _ eps_pos) as [bet [bet_pos Hbet]] ;
 exists (Rmin alp bet) ; split.
 apply Rmin_pos_lt ; assumption.
 intros y [Dy y_bd] ; rewrite <- Heq.
  apply Hbet ; split ; [assumption | apply Rlt_le_trans with (Rmin alp bet) ;
  [assumption | apply Rmin_r]].
 apply Rlt_le_trans with (Rmin alp bet) ; [apply y_bd | apply Rmin_l].
 assumption.
Qed.

(* TODO: WTF does this do here? *)
(** pr_nu_var restricted to a specific interval *)

Lemma pr_nu_var2_interv : forall (f g : R -> R) (lb ub x : R) (pr1 : derivable_pt f x)
       (pr2 : derivable_pt g x),
       open_interval lb ub x ->
       (forall h : R, lb < h < ub -> f h = g h) ->
       derive_pt f x pr1 = derive_pt g x pr2.
Proof.
intros f g lb ub x Prf Prg x_encad local_eq.
assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs g x l)).
 intros a l a_encad.
 unfold derivable_pt_abs, derivable_pt_lim.
 split.
 intros Hyp eps eps_pos.
 elim (Hyp eps eps_pos) ; intros delta Hyp2.
 assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0).
  clear-a lb ub a_encad delta.
  apply Rmin_pos_lt ; [exact (delta.(cond_pos)) | apply Rmin_pos_lt ] ;
  apply Rlt_Rminus ; intuition.
 exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond).
 intros h h_neq h_encad.
 replace (g (a + h) - g a) with (f (a + h) - f a).
 apply Hyp2 ; intuition.
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))).
 assumption. apply Rmin_l.
 assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h).
  intros ; apply Ropp_eq_compat ; intuition.
 rewrite local_eq ; unfold Rminus. rewrite local_eq2. reflexivity.
 assumption.
 assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
 split.
 assert (Sublemma : forall x y z, -z < y - x -> x < y + z).
  intros ; lra.
 apply Sublemma.
 apply Sublemma2. rewrite Rabs_Ropp.
 apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 assert (Sublemma : forall x y z, y < z - x -> x + y < z).
  intros ; lra.
 apply Sublemma.
 apply Sublemma2.
 apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 intros Hyp eps eps_pos.
 elim (Hyp eps eps_pos) ; intros delta Hyp2.
 assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0).
  clear-a lb ub a_encad delta.
  apply Rmin_pos_lt ; [exact (delta.(cond_pos)) | apply Rmin_pos_lt ] ;
  apply Rlt_Rminus ; intuition.
 exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond).
 intros h h_neq h_encad.
 replace (f (a + h) - f a) with (g (a + h) - g a).
 apply Hyp2 ; intuition.
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))).
 assumption. apply Rmin_l.
 assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h).
  intros ; apply Ropp_eq_compat ; intuition.
 rewrite local_eq ; unfold Rminus. rewrite local_eq2. reflexivity.
 assumption.
 assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
 split.
 assert (Sublemma : forall x y z, -z < y - x -> x < y + z).
  intros ; lra.
 apply Sublemma.
 apply Sublemma2. rewrite Rabs_Ropp.
 apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 assert (Sublemma : forall x y z, y < z - x -> x + y < z).
  intros ; lra.
 apply Sublemma.
 apply Sublemma2.
 apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 unfold derivable_pt in Prf.
  unfold derivable_pt in Prg.
  elim Prf; intros.
  elim Prg; intros.
  assert (Temp := p); rewrite H in Temp.
  unfold derivable_pt_abs in p.
  unfold derivable_pt_abs in p0.
  simpl in |- *.
  apply (uniqueness_limite g x x0 x1 Temp p0).
  assumption.
Qed.

(** Simplification lemmas on mult_real_fun *)

Lemma mult_real_fct_0: forall f,
  mult_real_fct 0 f == (fun _ => 0).
Proof.
intros f x ; unfold mult_real_fct ; apply Rmult_0_l.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Notations.

Delimit Scope zrange_scope with zrange.
Record zrange := { lower : Z ; upper : Z }.
Bind Scope zrange_scope with zrange.
Local Open Scope Z_scope.

Definition ZToZRange (z : Z) : zrange := {| lower := z ; upper := z |}.

Ltac inversion_zrange :=
  let lower := (eval cbv [lower] in (fun x => lower x)) in
  let upper := (eval cbv [upper] in (fun y => upper y)) in
  repeat match goal with
         | [ H : _ = _ :> zrange |- _ ]
           => pose proof (f_equal lower H); pose proof (f_equal upper H); clear H;
              cbv beta iota in *
         end.

(** All of the boundedness properties take an optional bitwidth, and
    enforce the condition that the range is within 0 and 2^bitwidth,
    if given. *)
Section with_bitwidth.
  Context (bitwidth : option Z).

  Definition is_bounded_by' : zrange -> Z -> Prop
    := fun bound val
       => lower bound <= val <= upper bound
          /\ match bitwidth with
             | Some sz => 0 <= lower bound /\ upper bound < 2^sz
             | None => True
             end.

  Definition is_bounded_by {n} : Tuple.tuple zrange n -> Tuple.tuple Z n -> Prop
    := Tuple.fieldwise is_bounded_by'.
End with_bitwidth.

Definition is_tighter_than_bool (x y : zrange) : bool
  := ((lower y <=? lower x) && (upper x <=? upper y))%bool%Z.

Global Instance dec_eq_zrange : DecidableRel (@eq zrange) | 10.
Proof.
  intros [lx ux] [ly uy].
  destruct (dec (lx = ly)), (dec (ux = uy));
    [ left; apply f_equal2; assumption
    | abstract (right; intro H; inversion_zrange; tauto).. ].
Defined.

Module Export Notations.
  Delimit Scope zrange_scope with zrange.
  Notation "r[ l ~> u ]" := {| lower := l ; upper := u |}
                              (format "r[ l  ~>  u ]") : zrange_scope.
  Infix "<=?" := is_tighter_than_bool : zrange_scope.
End Notations.


Require Import Logic.Axiom.Extensionality.

Require Import Logic.Rel.R.

Declare Scope Rel_Composition_scope.

(* Composition operator.                                                        *)
Definition comp (a b c:Type) (s:R b c) (r:R a b) : R a c :=
    fun (x:a) (z:c) => exists (y:b), r x y /\ s y z.

Arguments comp {a} {b} {c}.

Notation "s ; r" := (comp s r)
    (at level 60, right associativity) : Rel_Composition_scope.

Open Scope Rel_Composition_scope.

(* associativity law.                                                           *)
Lemma comp_assoc : forall (a b c d:Type) (r:R a b) (s:R b c) (t:R c d),
    (t ; s) ; r = t ; (s ; r).
Proof.
    intros a b c d r s t. apply Ext. intros x y. unfold comp. split.
    - intros [x' [H1 [y' [H2 H3]]]]. exists y'. split.
        + exists x'. split; assumption.
        + assumption.
    - intros [y' [[x' [H1 H2]] H3]]. exists x'. split.
        + assumption.
        + exists y'. split; assumption.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Require Export List.

Section Listes.

  Variable A : Set.

  Let List := list A.

  Inductive item (x : A) : List -> nat -> Prop :=
    | item_hd : forall l : List, item x (x :: l) 0
    | item_tl :
        forall (l : List) (n : nat) (y : A),
        item x l n -> item x (y :: l) (S n).

  Lemma fun_item :
   forall (u v : A) (e : List) (n : nat), item u e n -> item v e n -> u = v.
Proof.
simple induction 1; intros.
inversion_clear H0; auto.

inversion_clear H2; auto.
Qed.

  Lemma list_item :
   forall e n, {t : _ | item t e n} + {(forall t, ~ item t e n)}.
Proof.
fix item_rec 1.
intros [| h l].
right; red in |- *; intros t in_nil; inversion in_nil.

intros [| k].
left; exists h; constructor.

case (item_rec l k).
intros (y, in_tl); left; exists y; constructor; trivial.

intros not_in_tl; right; intros t in_tl_l; inversion_clear in_tl_l;
 red in not_in_tl; eauto.
Defined.

  Inductive trunc : nat -> List -> List -> Prop :=
    | trunc_O : forall e : List, trunc 0 e e
    | trunc_S :
        forall (k : nat) (e f : List) (x : A),
        trunc k e f -> trunc (S k) (x :: e) f.

  Lemma item_trunc :
   forall (n : nat) (e : List) (t : A),
   item t e n -> exists f : List, trunc (S n) e f.
Proof.
simple induction n; intros.
inversion_clear H.
exists l.
apply trunc_S.
apply trunc_O.

inversion_clear H0.
elim H with l t; intros.
exists x.
apply trunc_S.
trivial.

trivial.
Qed.

End Listes.

  Hint Resolve item_hd item_tl trunc_O trunc_S: core.


(** * Koindukcja (negatywna, czyli lepsza) *)

(** ** Strumienie *)

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

Arguments hd {A}.
Arguments tl {A}.

CoFixpoint from' (n : nat) : Stream nat :=
{|
    hd := n;
    tl := from' (S n);
|}.

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

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

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

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

CoFixpoint evens {A : Type} (s : Stream A) : Stream A :=
{|
    hd := hd s;
    tl := evens (tl (tl s));
|}.

(** Na tablicy można pisać za pomocą (ko?)równań.

    hd (evens s) := hd s;
    tl (evens s) := evens (tl (tl s));

*)

CoFixpoint odds {A : Type} (s : Stream A) : Stream A :=
{|
    hd := hd (tl s);
    tl := odds (tl (tl s));
|}.

Definition split {A : Type} (s : Stream A)
  : Stream A * Stream A := (evens s, odds s).

CoFixpoint merge
  {A : Type} (ss : Stream A * Stream A) : Stream A :=
{|
    hd := hd (fst ss);
    tl := merge (snd ss, tl (fst ss));
|}.

Lemma merge_split :
  forall (A : Type) (s : Stream A),
    bisim (merge (split s)) s.
Proof.
  unfold split.
  cofix CH.
  intros. constructor.
    cbn. reflexivity.
    cbn. constructor.
      cbn. reflexivity.
      cbn. apply CH.
Qed.

(** ** Kolisty *)

CoInductive LList (A : Type) : Type :=
{
    uncons : option (A * LList A);
}.

Arguments uncons {A}.

Definition lnil {A : Type} : LList A := {| uncons := None |}.

Definition lcons {A : Type} (x : A) (l : LList A) : LList A :=
  {| uncons := Some (x, l); |}.

CoFixpoint from (n : nat) : LList nat :=
  lcons n (from (S n)).

Inductive Finite {A : Type} : LList A -> Prop :=
    | Finite_nil : Finite lnil
    | Finite_cons :
        forall (h : A) (t : LList A),
          Finite t -> Finite (lcons h t).

CoInductive Infinite {A : Type} (l : LList A) : Prop :=
{
    h : A;
    t : LList A;
    p : uncons l = Some (h, t);
    inf' : Infinite t;
}.

(** * Indukcja i rekursja dobrze ufundowana *)

Module Wf.

Inductive Acc {A : Type} (R : A -> A -> Type) (x : A) : Prop :=
    | Acc_intro : (forall y : A, R y x -> Acc R y) -> Acc R x.

Definition well_founded {A : Type} (R : A -> A -> Type) : Prop :=
  forall x : A, Acc R x.

Lemma le_not_Acc :
  forall n : nat, Acc le n -> False.
Proof.
  induction 1. apply (H0 x). apply le_n.
Qed.

Lemma le_not_wf : ~ well_founded le.
Proof.
  unfold well_founded. intro.
  apply le_not_Acc with 0. apply H.
Qed.

Lemma lt_wf : well_founded lt.
Proof.
  unfold well_founded.
  induction x as [| n']; constructor; inversion 1; subst.
    assumption.
    inversion IHn'. apply H0. assumption.
Qed.

Theorem well_founded_induction_type :
  forall
    (A : Type) (R : A -> A -> Type)
    (wf : well_founded R) (P : A -> Type),
      (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
        forall x : A, P x.
Proof.
  intros A R wf P IH x.
  unfold well_founded in wf.
  specialize (wf x).
  induction wf.
  apply IH.
  assumption.
Defined.

End Wf.

(** ** Przykład: dzielenie i indukcja funkcyjna *)

Require Import Arith.
Require Import Omega.

Definition div : nat -> forall k : nat, 0 < k -> nat.
Proof.
  apply (@well_founded_induction_type nat lt lt_wf
    (fun n : nat => forall k : nat, 0 < k -> nat)).
  intros. destruct (le_lt_dec k x).
    Focus 2. exact 0.
    apply S. apply (H (x - k)) with k.
      apply Nat.sub_lt; assumption.
      assumption.
Defined.

Compute div 5 2 ltac:(omega).

Lemma div_le :
  forall (n m : nat) (H : 0 < m),
    div n m H <= n.
Proof.
  intros. revert n.
  apply (@well_founded_induction_type nat lt lt_wf).
  intros n IH.
  cbn. destruct (le_lt_dec m n).
    admit.
    apply le_0_n.
Abort.

Lemma div_lt_n_k :
  forall (n k : nat) (H : 0 < k),
    n < k -> div n k H = 0.
Proof.
  intros. cbn. destruct (le_lt_dec k n).
    omega.
    trivial.
Qed.

Lemma div_le_k_n :
  forall (n k : nat) (H : 0 < k),
    k <= n -> div n k H = S (div (n - k) k H).
Proof.
  apply (@well_founded_ind nat lt lt_wf
    (fun n => forall (k : nat) (H : 0 < k),
      k <= n -> div n k H = S (div (n - k) k H))).
  intros. cbn. destruct (le_lt_dec k x).
    f_equal.
Admitted.

Theorem div_eq :
  forall (n k : nat) (H : 0 < k), div n k H =
    match le_lt_dec k n with
        | left _ => S (div (n - k) k H)
        | right _ => 0
    end.
Proof.
  intros. destruct (le_lt_dec k n).
    rewrite div_le_k_n; auto.
    rewrite div_lt_n_k; auto.
Qed.

Lemma div_le :
  forall (n m : nat) (H : 0 < m),
    div n m H <= n.
Proof.
  intros.
  rewrite div_eq.
  destruct (le_lt_dec m n).
Abort.

Inductive divR : nat -> nat -> nat -> Prop :=
    | div_base :
        forall (n k : nat), 0 < k -> n < k -> divR n k 0
    | div_rec :
        forall (n k r : nat), 0 < k -> k <= n ->
          divR (n - k) k r -> divR n k (S r).

Hint Constructors divR.

Lemma divR_correct :
  forall (n k r : nat) (H : 0 < k),
    div n k H = r -> divR n k r.
Proof.
  apply (@well_founded_induction nat lt lt_wf
    (fun n : nat => forall (k r : nat) (H : 0 < k ),
      div n k H = r -> divR n k r)).
  intros. rewrite div_eq in H1. destruct (le_lt_dec k x); subst.
    Focus 2. constructor; auto.
    constructor; auto. apply H with H0; omega.
Qed.

Lemma divR_complete :
  forall (n k r : nat) (H : 0 < k),
    divR n k r -> div n k H = r.
Proof.
  induction 1.
    apply div_lt_n_k. assumption.
    rewrite <- IHdivR with H. rewrite div_le_k_n; auto.
Qed.

Theorem div_ind :
  forall P : nat -> nat -> nat -> Prop,
    (forall n k : nat, 0 < k -> n < k -> P n k 0) ->
    (forall (n k : nat) (H : 0 < k), k <= n ->
      P (n - k) k (div (n - k) k H) -> P n k (S (div (n - k) k H))) ->
        forall (n k : nat) (H : 0 < k), P n k (div n k H).
Proof.
  intros. apply divR_ind; intros.
    apply H; auto.
    eapply (divR_complete _ _ _ H2) in H4. subst. apply H0; assumption.
    apply divR_correct with H1. reflexivity.
Qed.

Lemma div_le :
  forall (n m : nat) (H : 0 < m),
    div n m H <= n.
Proof.
  apply (div_ind (fun n m r => r <= n)).
    intros. apply le_0_n.
    intros. destruct n as [| n'].
      omega.
      apply le_n_S. omega.
Qed.

Require Import Recdef.

(** div' n m = n/(m + 1) *)
Function div' (n m : nat) {measure id n} : nat :=
  if le_lt_dec (S m) n
  then S (div' (n - S m) m)
  else 0.
Proof.
  intros. unfold id. omega.
Defined.

Print R_div'.
Check R_div'_correct.
Check R_div'_complete.
Check div'_ind.

Lemma div'_le :
  forall n m : nat, div' n m <= n.
Proof.
  intros. functional induction (div' n m).
    omega.
    apply le_0_n.
Defined.

(** * Plugin Equations *)

(** Niestety zabrakło czasu na customowy przykład, a głębsze wyjaśnienia nie
    miały większego sensu. Żeby dowiedzieć się więcej, zrób zadanie 8. *)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2014-12-11

useful definitions and lemmas on functions
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil.

(****************************************************************************)
(** Some properties of functions. *)

Section functions.

  Variables (A B : Type) (f : A -> B).

  Definition injective := forall x y, f x = f y -> x = y.

  Definition surjective := forall y, exists x, y = f x.

  Definition bijective := injective /\ surjective.

End functions.

(****************************************************************************)
(** Function composition. *)

Section comp.

  Variables (A B C : Type) (f : B -> C) (g : A -> B).

  Definition comp x := f (g x).

  Lemma inj_comp : injective f -> injective g -> injective comp.

  Proof.
    intros f_inj g_inj x y e. apply f_inj in e. apply g_inj in e. hyp.
  Qed.

  Lemma inj_comp_elim : injective comp -> injective g.

  Proof.
    intros comp_inj x y e. apply comp_inj. unfold comp. rewrite e. refl.
  Qed.

  Lemma surj_comp : surjective f -> surjective g -> surjective comp.

  Proof.
    intros f_surj g_surj z. destruct (f_surj z) as [y hy].
    destruct (g_surj y) as [x hx]. ex x. subst. refl.
  Qed.

  Lemma surj_comp_elim : surjective comp -> surjective f.

  Proof.
    intros comp_surj y. destruct (comp_surj y) as [x e]. subst. ex (g x). refl.
  Qed.

  Lemma bij_comp : bijective f -> bijective g -> bijective comp.

  Proof.
    intros f_bij g_bij. split. apply inj_comp; fo. apply surj_comp; fo.
  Qed.

End comp.

Infix "o" := comp (at level 70).

(****************************************************************************)
(** Inverse of a surjective function, using Hilbert's epsilon operator. *)

From CoLoR Require Import EpsilonUtil.

Section inverse.

  Variables (A B : Type) (f : A -> B) (f_surj : surjective f).

  Definition inverse : B -> A.

  Proof. intro y. destruct (cid (f_surj y)) as [x _]. exact x. Defined.

  Lemma inverse_eq y : f (inverse y) = y.

  Proof. unfold inverse. destruct (cid (f_surj y)) as [x e]. auto. Qed.

  Lemma inj_inverse : injective inverse.

  Proof.
    intros x y e. apply (f_equal f) in e. rewrite !inverse_eq in e. hyp.
  Qed.

End inverse.

(****************************************************************************)
(** Tactics for injectivity, surjective and bijectivity. *)

Ltac inj :=
  match goal with
    | |- injective (_ o _) => apply inj_comp; inj
    | |- injective (inverse _) => apply inj_inverse; inj
    | |- injective _ => auto
  end.

Ltac surj :=
  match goal with
    | |- surjective (_ o _) => apply surj_comp; surj
    | |- surjective _ => auto
  end.

Ltac bij :=
  match goal with
    | |- bijective (_ o _) => apply bij_comp; bij
    | |- bijective _ => hyp || (split; [inj | surj])
  end.


Require Export Complex.
Require Export Quantum.
Require Export Init.Datatypes.
Require Export Coq.Sorting.Permutation.
Require Export Coq.Lists.List.
(** This file provides padding functions to extend a matrix to a larger space.
   This is useful for describing the effect of 1- and 2-qubit gates on a larger
   quantum space. *)

(* if_matrix notation + lemmas *)

Definition if_matrix {n} (b : bool) (u1 u2 : Square n) : Square n :=
  if b then u1 else u2.

Lemma WF_if_matrix : forall (n : nat) (b : bool) (u1 u2 : Square n),
WF_Matrix u1 -> WF_Matrix u2 -> WF_Matrix (if_matrix b u1 u2).
Proof.
  intros. destruct b; assumption.
Qed.

Notation "A <| b |> B" := (if_matrix b A B) (at level 30).

Lemma if_matrix_mul : forall b n (A B C D : Square n),
    (A <|b|> B) × (C <| b |> D) = (A × C) <| b |> (B × D).
Proof.
  destruct b; reflexivity.
Qed.

#[export] Hint Resolve WF_if_matrix : wf_db.

Definition pad {n} (start dim : nat) (A : Square (2^n)) : Square (2^dim) :=
  if start + n <=? dim then I (2^start) ⊗ A ⊗ I (2^(dim - (start + n))) else Zero.

Lemma WF_pad : forall n start dim (A : Square (2^n)),
  WF_Matrix A ->
  WF_Matrix (pad start dim A).
Proof.
  intros n start dim A WFA. unfold pad.
  bdestruct (start + n <=? dim); auto with wf_db.
Qed.

Lemma pad_mult : forall n dim start (A B : Square (2^n)),
  pad start dim A × pad start dim B = pad start dim (A × B).
Proof.
  intros.
  unfold pad.
  gridify.
  reflexivity.
Qed.

Lemma pad_id : forall n dim,
  (n < dim)%nat -> @pad 1 n dim (I 2) = I (2 ^ dim).
Proof. intros. unfold pad. gridify. reflexivity. Qed.

Definition pad_u (dim n : nat) (u : Square 2) : Square (2^dim) := @pad 1 n dim u.

Definition pad_ctrl (dim m n: nat) (u: Square 2) :=
  if (m <? n) then
    @pad (1+(n-m-1)+1) m dim (∣1⟩⟨1∣ ⊗ I (2^(n-m-1)) ⊗ u .+ ∣0⟩⟨0∣ ⊗ I (2^(n-m-1)) ⊗ I 2)
  else if (n <? m) then
    @pad (1+(m-n-1)+1) n dim (u ⊗ I (2^(m-n-1)) ⊗ ∣1⟩⟨1∣ .+ I 2 ⊗ I (2^(m-n-1)) ⊗ ∣0⟩⟨0∣)
  else
    Zero.

(* also possible to define this in terms of pad directly *)
Definition pad_swap (dim m n: nat) :=
  pad_ctrl dim m n σx × pad_ctrl dim n m σx × pad_ctrl dim m n σx.

(** Well-formedness *)

Lemma WF_pad_u : forall dim n u, WF_Matrix u -> WF_Matrix (pad_u dim n u).
Proof.
  intros.
  unfold pad_u.
  apply WF_pad; easy.
Qed.

Lemma WF_pad_ctrl : forall dim m n u, WF_Matrix u -> WF_Matrix (pad_ctrl dim m n u).
  intros.
  unfold pad_ctrl.
  assert (H' : forall n, (2 * 2 ^ n * 2 = 2 ^ (1 + n + 1))%nat).
  { intros.
    do 2 rewrite Nat.pow_add_r, Nat.pow_1_r; easy. }
  bdestruct (m <? n); bdestruct (n <? m); try lia; auto with wf_db.
  all : apply WF_pad; rewrite H'; apply WF_plus; auto with wf_db.
Qed.

Lemma WF_pad_swap : forall dim m n, WF_Matrix (pad_swap dim m n).
  intros.
  unfold pad_swap.
  repeat apply WF_mult; apply WF_pad_ctrl; apply WF_σx.
Qed.

#[export] Hint Resolve WF_pad WF_pad_u WF_pad_ctrl WF_pad_swap : wf_db.

(* pad2x2, embed definition + lemmas about commutation *)
Definition pad2x2 {dim : nat} (A : Square 2) (i : nat) : Square (2^dim) :=
  if (i <? dim) then (I (2^i) ⊗ A ⊗ I (2^(dim - i - 1))) else Zero.

Lemma WF_pad2x2 : forall (i dim : nat) (A : Square 2),
WF_Matrix A -> WF_Matrix (@pad2x2 dim A i).
Proof.
  intros i dim A WF_A. unfold pad2x2.
  bdestruct_all; simpl; auto with wf_db.
Qed.

#[export] Hint Resolve WF_pad2x2 : wf_db.

Fixpoint embed {dim : nat} (lp : (list ((Square 2) * nat))) : Square (2^dim)  :=
  match lp with
  | (A, i) :: lp' => @Mmult (2^dim) (2^dim) (2^dim) (@pad2x2 dim A i) (embed lp')
  | _         => I (2^dim)
  end.

Lemma pad2x2_commutes : forall (A B : Square 2) (i j dim : nat),
i <> j ->
WF_Matrix A ->
WF_Matrix B ->
@pad2x2 dim A i × @pad2x2 dim B j = @pad2x2 dim B j × @pad2x2 dim A i.
Proof.
  intros. unfold pad2x2.
  gridify; trivial.
  Qed.

Lemma WF_embed : forall (dim : nat) (lp : (list ((Square 2) * nat))),
Forall WF_Matrix (map fst lp) ->
NoDup (map snd lp) ->
Forall (fun n => (n < dim)%nat) (map snd lp) ->
WF_Matrix (@embed dim lp).
intros. induction lp.
+ unfold embed; auto with wf_db.
+ destruct a. bdestruct (n <? dim); Msimpl; auto with wf_db.
  - inversion H; subst. inversion H0; subst. inversion H1; subst.
   simpl. apply WF_mult; auto with wf_db.
  - inversion H1; subst. lia.
Qed.

#[export] Hint Resolve WF_embed : wf_db.

Lemma embed_commutes_base : forall (i j dim : nat)(A B : Square 2)
(lp : (list ((Square 2) * nat))),
  i <> j ->
  WF_Matrix A ->
  WF_Matrix B ->
  (i < dim)%nat ->
  (j < dim)%nat ->
  @embed dim ((A, i) :: (B, j) :: lp) = @embed dim ((B, j) :: (A, i) :: lp).
  Proof.
    intros. simpl. rewrite <- Mmult_assoc. rewrite pad2x2_commutes; trivial.
    apply Mmult_assoc.
  Qed.

Lemma embed_commutes : forall (dim : nat) (lp1 lp2 : list ((Square 2) * nat)),
  Forall WF_Matrix (map fst lp1) ->
  NoDup (map snd lp1) ->
  Forall (fun n => (n < dim)%nat) (map snd lp1) ->
  Permutation lp1 lp2 ->
  @embed dim lp1 = @embed dim lp2.
  Proof.
    intros. induction H2; trivial.
    + simpl. rewrite IHPermutation; trivial.
      - simpl in *. inversion H; subst.
      auto.
      - inversion H0; auto.
      - simpl in H1.
        apply Forall_inv_tail in H1.
        assumption.
    + destruct x, y. apply embed_commutes_base.
      - simpl in H0. inversion H0; subst. simpl in *. intros n0eqn. apply H4. auto.
      - simpl in *. inversion H; subst.
      auto.
      - inversion H; subst. inversion H5; subst.
      auto.
      - inversion H1; auto.
      - inversion H1; subst. inversion H5; auto.
    + pose proof (Permutation_map snd H2_). rewrite IHPermutation1;
    try rewrite IHPermutation2; trivial.
      - apply (Permutation_map fst) in H2_. eapply Permutation_Forall; eauto.
      - apply (Permutation_NoDup H2 H0).
      - eapply Permutation_Forall; eauto.
    Qed.

Lemma embed_mult : forall (dim : nat) (lp1 lp2 : list ((Square 2) * nat)),
Forall WF_Matrix (map fst lp1) ->
Forall WF_Matrix (map fst lp2) ->
NoDup (map snd lp1) ->
NoDup (map snd lp2) ->
Forall (fun n : nat => (n < dim)%nat) (map snd lp1) ->
Forall (fun n : nat => (n < dim)%nat) (map snd lp2) ->
@embed dim lp1 × @embed dim lp2 = @embed dim (lp1 ++ lp2).
Proof.
  intros. induction lp1.
  + simpl. apply Mmult_1_l. apply WF_embed; trivial.
  + simpl. rewrite <- IHlp1. destruct a. apply Mmult_assoc.
  inversion H; auto.
  inversion H1; auto.
  inversion H3; auto.
Qed.

(* TODO: find function in stdlib *)
Definition abs_diff (a b : nat) := Nat.max (a - b) (b - a).

Definition pad2x2_ctrl (dim m n : nat) (u : Square 2) : Square (2^dim)%nat :=
  if m =? n then Zero
  else
    let b := m <? n in
    let μ := min m n in
    let δ := abs_diff m n in
    (@embed dim
    ([((∣1⟩⟨1∣ <|b|> u), μ)] ++
    [((u <|b|> ∣1⟩⟨1∣), (μ + δ)%nat)]))
    .+
    (@embed dim
    ([((∣0⟩⟨0∣ <|b|> I 2), μ)] ++
    [((I 2 <|b|> ∣0⟩⟨0∣), (μ + δ)%nat)])).

Ltac rem_max_min :=
   unfold gt, ge, abs_diff in *;
  repeat match goal with
  | [ H: (?a < ?b)%nat |- context[Nat.max (?a - ?b) (?b - ?a)] ] =>
    rewrite (Max.max_r (a - b) (b - a)) by lia
  | [ H: (?a < ?b)%nat |- context[Nat.max (?b - ?a) (?a - ?b)] ] =>
    rewrite (Max.max_l (b - a) (a - b)) by lia
  | [ H: (?a <= ?b)%nat |- context[Nat.max (?a - ?b) (?b - ?a)] ] =>
    rewrite (Max.max_r (a - b) (b - a)) by lia
  | [ H: (?a <= ?b)%nat |- context[Nat.max (?b - ?a) (?a - ?b)] ] =>
    rewrite (Max.max_l (b - a) (a - b)) by lia
  | [ H: (?a < ?b)%nat |- context[Nat.min ?a ?b] ] =>
    rewrite Min.min_l by lia
  | [ H: (?a < ?b)%nat |- context[Nat.max ?a ?b] ] =>
    rewrite Max.max_r by lia
  | [ H: (?a < ?b)%nat |- context[Nat.min ?b ?a] ] =>
    rewrite Min.min_r by lia
  | [ H: (?a < ?b)%nat |- context[Nat.max ?b ?a] ] =>
    rewrite Max.max_l by lia
  | [ H: (?a <= ?b)%nat |- context[Nat.min ?a ?b] ] =>
    rewrite Min.min_l by lia
  | [ H: (?a <= ?b)%nat |- context[Nat.max ?a ?b] ] =>
    rewrite Max.max_r by lia
  | [ H: (?a <= ?b)%nat |- context[Nat.min ?b ?a] ] =>
    rewrite Min.min_r by lia
  | [ H: (?a <= ?b)%nat |- context[Nat.max ?b ?a] ] =>
    rewrite Max.max_l by lia
  end.

Definition pad2x2_u (dim n : nat) (u : Square 2) : Square (2^dim) := @embed dim [(u,n)].

(* also possible to define this in terms of pad2x2 directly *)
Definition pad2x2_swap (dim m n: nat) :=
  pad2x2_ctrl dim m n σx × pad2x2_ctrl dim n m σx × pad2x2_ctrl dim m n σx.

(** Well-formedness *)

Lemma WF_pad2x2_u : forall dim n u, WF_Matrix u -> WF_Matrix (pad2x2_u dim n u).
Proof.
  intros.
  unfold pad2x2_u.
  unfold embed.
  auto with wf_db.
Qed.

Lemma WF_pad2x2_ctrl : forall dim m n u, WF_Matrix u -> WF_Matrix (pad2x2_ctrl dim m n u).
Proof.
  intros dim m n u WF_u.
  unfold pad2x2_ctrl, abs_diff. bdestruct_all; simpl; rem_max_min;
  restore_dims; auto with wf_db.
  Qed.

Lemma WF_pad2x2_swap : forall dim m n, WF_Matrix (pad2x2_swap dim m n).
  intros.
  unfold pad2x2_swap.
  repeat apply WF_mult; apply WF_pad2x2_ctrl; apply WF_σx.
Qed.

#[export] Hint Resolve WF_pad2x2 WF_pad2x2_u WF_pad2x2_ctrl WF_pad2x2_swap : wf_db.

(* tactics for NoDup *)
Ltac NoDupity :=
  repeat match goal with
  | |- NoDup [?a] => repeat constructor; auto
  | |- NoDup _=> repeat constructor; intros []; try lia; auto
  | [ H1: In ?a ?b |- False ] => inversion H1; auto
  end.

(* Lemmas about commutativity *)

Lemma pad2x2_A_B_commutes : forall dim m n A B,
  m <> n ->
  (m < dim)%nat ->
  (n < dim)%nat ->
  WF_Matrix A ->
  WF_Matrix B ->
  pad2x2_u dim m A × pad2x2_u dim n B = pad2x2_u dim n B × pad2x2_u dim m A.
Proof.
  intros. unfold pad2x2_u. unfold WF_Matrix in *.
  repeat rewrite embed_mult. apply embed_commutes.
  all : simpl; try auto with wf_db; NoDupity.
  constructor.
Qed.

Ltac comm_pad2x2 :=
  repeat match goal with
  | |- context[?A = ?B] => match A with
      | context[@pad2x2 ?dim ?X ?x × @pad2x2 ?dim ?Y ?y × @pad2x2 ?dim ?Z ?z] =>
      match B with
        | context[pad2x2 Z z × pad2x2 X x × pad2x2 Y y] =>
          try rewrite (pad2x2_commutes Z X z x dim);
          try rewrite <- (Mmult_assoc (pad2x2 X x) (pad2x2 Z z) (pad2x2 Y y));
          try rewrite (pad2x2_commutes Y Z y z dim)
        | context[pad2x2 Y y × pad2x2 Z z × pad2x2 X x] =>
          try rewrite (Mmult_assoc (pad2x2 Y y) (pad2x2 Z z) (pad2x2 X x));
          try rewrite (pad2x2_commutes Z X z x dim);
          try rewrite <- (Mmult_assoc (pad2x2 Y y) (pad2x2 X x) (pad2x2 Z z));
          try rewrite (pad2x2_commutes Y X y x dim)
        end
      | context[@pad2x2 ?dim ?X ?x × (@pad2x2 ?dim ?Y ?y × @pad2x2 ?dim ?Z ?z)] =>
        rewrite <- (Mmult_assoc (pad2x2 X x) (pad2x2 Y y) (pad2x2 Z z))
      end
    end.

Lemma pad2x2_A_ctrl_commutes : forall dim m n o A B,
  m <> n ->
  m <> o ->
  (m < dim)%nat ->
  (n < dim)%nat ->
  (o < dim)%nat ->
  WF_Matrix A ->
  WF_Matrix B ->
  pad2x2_u dim m A × pad2x2_ctrl dim n o B = pad2x2_ctrl dim n o B × pad2x2_u dim m A.
Proof.
  Opaque embed.
  intros. unfold pad2x2_u, pad2x2_ctrl, abs_diff. bdestruct_all; simpl; rem_max_min;
  Msimpl; trivial.
  + repeat rewrite Mmult_plus_distr_l; repeat rewrite Mmult_plus_distr_r.
  rewrite le_plus_minus_r by (apply Nat.lt_le_incl; trivial).
  repeat rewrite embed_mult; simpl.
  rewrite (embed_commutes dim [(A, m); (∣1⟩⟨1∣, n); (B, o)] [(∣1⟩⟨1∣, n); (B, o); (A, m)]).
  rewrite (embed_commutes dim [(A, m); (∣0⟩⟨0∣, n); (I 2, o)] [(∣0⟩⟨0∣, n); (I 2, o); (A, m)]).
  trivial.
  all : simpl; NoDupity; auto with wf_db.
  all : rewrite perm_swap; apply perm_skip; apply perm_swap.

  + repeat rewrite Mmult_plus_distr_l; repeat rewrite Mmult_plus_distr_r.
  rewrite le_plus_minus_r by trivial; repeat rewrite embed_mult; simpl.
  rewrite (embed_commutes dim [(A, m); (B, o); (∣1⟩⟨1∣, n)] [(B, o); (∣1⟩⟨1∣, n); (A, m)]).
  rewrite (embed_commutes dim [(A, m); (I 2, o); (∣0⟩⟨0∣, n)] [(I 2, o); (∣0⟩⟨0∣, n); (A, m)]).
  trivial.
  all : simpl; NoDupity; auto with wf_db.
  all : rewrite perm_swap; apply perm_skip; apply perm_swap.
  Qed.

(** Unitarity *)

Lemma pad_unitary : forall n (u : Square (2^n)) start dim,
    (start + n <= dim)%nat ->
    WF_Unitary u ->
    WF_Unitary (pad start dim u).
Proof.
  intros n u start dim B [WF U].
  split. apply WF_pad; auto.
  unfold pad.
  gridify.
  Msimpl.
  rewrite U.
  reflexivity.
Qed.

Lemma pad_u_unitary : forall dim n u,
    (n < dim)%nat ->
    WF_Unitary u ->
    WF_Unitary (pad_u dim n u).
Proof. intros. apply pad_unitary. lia. auto. Qed.

Lemma pad_ctrl_unitary : forall dim m n u,
    m <> n ->
    (m < dim)%nat ->
    (n < dim)%nat ->
    WF_Unitary u ->
    WF_Unitary (pad_ctrl dim m n u).
Proof.
  intros dim m n u NE Lm Ln WFU.
  unfold pad_ctrl, pad.
  destruct WFU as [WF U].
  gridify.
  - split.
    + apply WF_plus; auto with wf_db.
    + Qsimpl.
      gridify.
      rewrite U.
      Qsimpl.
      repeat rewrite <- kron_plus_distr_r.
      repeat rewrite <- kron_plus_distr_l.
      Qsimpl.
      reflexivity.
  - split.
    + apply WF_plus; auto with wf_db.
    + Msimpl.
      gridify.
      rewrite U.
      Qsimpl.
      repeat rewrite <- kron_plus_distr_r.
      repeat rewrite <- kron_plus_distr_l.
      Qsimpl.
      reflexivity.
Qed.

Lemma pad_swap_unitary : forall dim m n,
    m <> n ->
    (m < dim)%nat ->
    (n < dim)%nat ->
    WF_Unitary (pad_swap dim m n).
Proof.
  intros.
  repeat apply Mmult_unitary;
    apply pad_ctrl_unitary; auto; apply σx_unitary.
Qed.

(** Lemmas about commutation *)

Lemma pad_A_B_commutes : forall dim m n A B,
  m <> n ->
  WF_Matrix A ->
  WF_Matrix B ->
  pad_u dim m A × pad_u dim n B = pad_u dim n B × pad_u dim m A.
Proof.
  intros.
  unfold pad_u, pad.
  gridify; trivial.
Qed.

(* A bit slow, due to six valid subcases *)
Lemma pad_A_ctrl_commutes : forall dim m n o A B,
  m <> n ->
  m <> o ->
  WF_Matrix A ->
  WF_Matrix B ->
  pad_u dim m A × pad_ctrl dim n o B = pad_ctrl dim n o B × pad_u dim m A.
Proof.
  intros.
  unfold pad_ctrl, pad_u, pad.
  gridify; trivial.
Qed.

(* Horribly slow due to many subcases.
   TODO: can we speed this up be tweaking the ordering in gridify? *)
Lemma pad_ctrl_ctrl_commutes : forall dim m n o p A B,
  m <> o ->
  m <> p ->
  n <> o ->
  n <> p ->
  WF_Matrix A ->
  WF_Matrix B ->
  pad_ctrl dim m n A × pad_ctrl dim o p B = pad_ctrl dim o p B × pad_ctrl dim m n A.
Proof.
  intros.
  unfold pad_ctrl, pad.
  bdestruct_all.
  all : try rewrite Mmult_0_r; try rewrite Mmult_0_l; try easy.
  all: gridify; trivial.
Qed.