(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Leclerc

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import
    ssreflect
    ssrsearch
    Lia
    Utf8

    ClassicalDescription
    Rdefinitions
    Rbasic_fun
.

From Coquelicot Require Import
    Hierarchy
    Rbar
.

Require Import
    measure
    sigma_algebra
    sum_Rbar_nonneg
    Rbar_compl
.

Require Import
    simpl_fun
    square_bij
    hierarchy_notations
.

Open Scope hy_scope.

Section BInt_for_sf.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : cette fois c'est nécessairement un R-module
    (en fait je pense qu'on pourrait prendre un surcorps de R mais je ne vois pas comment
    formaliser celà simplement) *)
    Context {E : NormedModule R_AbsRing}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.

    Open Scope R_scope.

    (* Une définition calculable de l'intégrale de Bochner d'une fonction simple *)
    Definition BInt_sf (μ : measure gen) (sf : simpl_fun _ gen) : E :=
        sum_n
            (fun n => scal (real (μ (nth_carrier sf n))) (sf.(val) n))
            (sf.(max_which)).

End BInt_for_sf.

Notation "'∫B' sf 'd' μ" := (BInt_sf μ sf)
        (only printing, at level 45, format "'[ ' '∫B'  sf  'd' μ ']'") : sf_scope.

Section BInt_sf_indic.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : R *)
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Open Scope R_scope.
    Open Scope fun_scope.

    Lemma BInt_sf_indic (P : X -> Prop) (π_meas : measurable gen P)
        : BInt_sf μ (sf_indic_aux gen P π_meas) = real (μ P).
    Proof.
        unfold BInt_sf.
        replace (max_which (sf_indic_aux gen P π_meas)) with 1%nat at 1
            by unfold sf_indic_aux => //.
        rewrite sum_Sn sum_O.
        case_eq (sf_indic_aux gen P π_meas) => wP vP maxP axP1 axP2 axP3 EqP;
            unfold nth_carrier; rewrite <-EqP => /=.
        rewrite (measure_ext gen μ _ P).
            all : swap 1 2.
            move => x; case: (excluded_middle_informative (P x)) => //.
        rewrite scal_zero_r plus_zero_r.
        unfold scal => /=.
        unfold mult => /=.
        rewrite RIneq.Rmult_1_r => //.
    Qed.

End BInt_sf_indic.

Open Scope nat_scope.

Lemma sum_n_m_scal_r {A : Ring} {E : ModuleSpace A} :
    ∀ a : nat -> A, ∀ u : E, ∀ n m : nat,
        sum_n_m (fun k : nat => scal (a k) u) n m = scal (sum_n_m (fun k : nat => (a k)) n m) u.
Proof.
    move => a u n.
    induction n => m.
        induction m.
        do 2 rewrite sum_n_n => //.
        rewrite sum_n_Sm. 2 : lia.
        rewrite sum_n_Sm. 2 : lia.
        rewrite scal_distr_r.
        rewrite IHm => //.
    case_eq (n <=? m).
        move /Nat.leb_le => Hnm.
        pose IHnm := IHn m; clearbody IHnm.
        rewrite sum_Sn_m in IHnm. 2 : lia.
        rewrite [in RHS]sum_Sn_m in IHnm. 2 : lia.
        rewrite scal_distr_r in IHnm.
        apply (plus_reg_l (scal (a n) u)) => //.
        move /Nat.leb_gt => Hmn.
        rewrite sum_n_m_zero. 2 : lia.
        rewrite sum_n_m_zero. 2 : lia.
        rewrite scal_zero_l => //.
Qed.

Lemma sum_n_scal_r {A : Ring} {E : ModuleSpace A} :
    ∀ a : nat -> A, ∀ u : E, ∀ n m : nat,
        sum_n (fun k : nat => scal (a k) u) n = scal (sum_n (fun k : nat => (a k)) n) u.
Proof.
    unfold sum_n => a u n m.
    apply sum_n_m_scal_r.
Qed.

Lemma sum_n_sum_Rbar :
    ∀ u : nat -> Rbar, ∀ n : nat, (∀ k : nat, k <= n -> is_finite (u k))
    -> sum_n (fun k => real (u k)) n = real (sum_Rbar n u).
Proof.
    induction n.
        rewrite sum_O.
        unfold sum_Rbar => //.
        move => Hu.
        rewrite sum_Sn.
        rewrite IHn.
            all : swap 1 2.
            move => k Hkn.
            assert (k <= S n) by lia.
        apply Hu => //; clear Hu.
        assert (S n <= S n) by lia.
        pose Le0uSn := Hu (S n) H; clearbody Le0uSn; clear H.
        assert (∀ k : nat, k ≤ n -> is_finite (u k)).
            move => k Hk.
            assert (k ≤ S n) by lia.
            apply Hu => //.
        pose Le0sum := finite_sum_Rbar u n H; clearbody Le0sum; clear H.
        simpl; rewrite Rbar_plus_comm.
        unfold Rbar_plus, Rbar_plus'.
        unfold is_finite in Le0sum, Le0uSn.
        rewrite <-Le0uSn, <-Le0sum => //.
Qed.

Section BInt_sf_plus.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : cette fois c'est nécessairement un R-module
    (en fait je pense qu'on pourrait prendre un surcorps de R mais je ne vois pas comment
    formaliser celà simplement) *)
    Context {E : NormedModule R_AbsRing}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Open Scope R_scope.
    Open Scope nat_scope.
    Open Scope sf_scope.

    Lemma BInt_sf_plus_aux {sf_f sf_g : simpl_fun E gen} :
        integrable_sf μ sf_f -> integrable_sf μ sf_g ->
            BInt_sf μ (sf_f + sf_g) = ((BInt_sf μ sf_f) + (BInt_sf μ sf_g))%hy.
    Proof.
        unfold integrable_sf => axf4 axg4.
        case_eq sf_f => wf vf maxf axf1 axf2 axf3 Eqf.
        case_eq sf_g => wg vg maxg axg1 axg2 axg3 Eqg.
        rewrite Eqf Eqg in axf4 axg4; simpl in axf4, axg4.
        rewrite <-Eqf, <- Eqg.
        unfold BInt_sf.
        replace (max_which sf_f) with maxf by rewrite Eqf => //.
        replace (max_which sf_g) with maxg by rewrite Eqg => //.
        replace (max_which (sf_f + sf_g)) with ((S maxf) * (S maxg) - 1)%nat.
            2 : rewrite Eqf Eqg => //.
        unfold nth_carrier.
        rewrite square_bij_sum.
        pose valfg := val (sf_f + sf_g).
            fold valfg.
            assert (valfg = simpl_fun.val (sf_f + sf_g))
                as Eqval by unfold valfg => //.
            clearbody valfg; rewrite Eqf Eqg in Eqval; simpl in Eqval.
            rewrite Eqval; clear Eqval valfg.
        pose whichfg := which (sf_f + sf_g).
            fold whichfg.
            assert (whichfg = which (sf_f + sf_g))
                as Eqwhich by unfold whichfg => //.
            clearbody whichfg; rewrite Eqf Eqg in Eqwhich; simpl in Eqwhich.
            rewrite Eqwhich; clear Eqwhich whichfg.
        assert
            (∀ k1 k2 : nat, k2 <= maxg ->
                (μ
                    (λ x : X,
                        square_bij (S maxg) (wf x, wg x) =
                        square_bij (S maxg) (k1, k2))
                ) =
                (μ
                    (λ x : X,
                        wf x = k1 ∧ wg x = k2
                    )
                )
            ) as Eqμ.
            move => k1 k2 Hk2.
            apply measure_ext => x; split.
                move => Eqwfk.
                assert
                    (square_bij_inv (S maxg)
                        (square_bij (S maxg) (wf x, wg x))
                    =
                    square_bij_inv (S maxg)
                        (square_bij (S maxg) (k1, k2))
                    ) as Eqaux by congruence.
                rewrite is_bij_square in Eqaux.
                    2 : apply axg2.
                rewrite is_bij_square in Eqaux.
                    2 : assumption.
                split; congruence.
                case => -> -> //.
        assert
            (∀ k1 k2 : nat, k2 <= maxg ->
                (let (nf, ng) :=
                    square_bij_inv (S maxg) (square_bij (S maxg) (k1, k2)) in
                    plus (vf nf) (vg ng))
                = plus (vf k1) (vg k2)
            ) as Eqsum.
            move => k1 k2 Hk2.
            rewrite is_bij_square.
                2 : assumption.
            reflexivity.
        assert
            (∀ k1 k2 : nat, k2 <= maxg ->
                scal
                    (real (μ
                    (λ x : X,
                        square_bij (S maxg) (wf x, wg x) =
                        square_bij (S maxg) (k1, k2))))
                    (let (nf, ng) :=
                    square_bij_inv (S maxg) (square_bij (S maxg) (k1, k2)) in
                    plus (vf nf) (vg ng))
                =
                scal
                    (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                    (plus (vf k1) (vg k2))
            ) as Eqsum1.
            move => k1 k2 Hk2.
            rewrite Eqsum. 2 : assumption.
            rewrite Eqμ. 2 : assumption.
            reflexivity.
        clear Eqsum Eqμ.
        assert
            (∀ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        scal
                            (real (μ
                            (λ x : X,
                                square_bij (S maxg) (wf x, wg x) =
                                square_bij (S maxg) (k1, k2))))
                            (let (nf, ng) :=
                            square_bij_inv (S maxg) (square_bij (S maxg) (k1, k2)) in
                            plus (vf nf) (vg ng))
                    ) maxg
                =
                sum_n
                    (λ k2 : nat,
                        scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (plus (vf k1) (vg k2))
                    ) maxg
            ) as Eqsum.
            move => k1.
            apply sum_n_ext_loc => k2 Hk2.
            apply Eqsum1 => //.
        assert
            (sum_n
            (λ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        scal
                        (real (μ
                            (λ x : X,
                            square_bij (S maxg) (wf x, wg x) =
                            square_bij (S maxg) (k1, k2))))
                        (let (nf, ng) :=
                            square_bij_inv (S maxg) (square_bij (S maxg) (k1, k2)) in
                            plus (vf nf) (vg ng))
                    ) maxg
                ) maxf
            =
            sum_n
            (λ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        scal
                        (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                        (plus (vf k1) (vg k2))
                    ) maxg
                ) maxf
            ) as Rwrt
            by apply sum_n_ext => //.
        rewrite Rwrt; clear Rwrt Eqsum Eqsum1.
        assert
            (∀ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        scal
                        (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                        (plus (vf k1) (vg k2))
                ) maxg
                =
                sum_n
                    (λ k2 : nat,
                        plus
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vf k1))
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vg k2))
                ) maxg
            ) as Eqsum.
            move => k1.
            apply sum_n_ext_loc => k2 Hk2.
            rewrite scal_distr_l => //.
        assert
            (sum_n
                (λ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        scal
                        (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                        (plus (vf k1) (vg k2))
                ) maxg
            ) maxf
            =
            sum_n
                (λ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        plus
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vf k1))
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vg k2))
                ) maxg
            ) maxf
            ) as Rwrt
            by apply sum_n_ext => //.
        rewrite Rwrt; clear Rwrt Eqsum.
        assert
            (∀ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        plus
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vf k1))
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vg k2))
                ) maxg
                =
                plus
                    (sum_n
                        (λ k2 : nat,
                            scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vf k1)
                    ) maxg)
                    (sum_n
                        (λ k2 : nat,
                            scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vg k2)
                    ) maxg)
            ) as Eqsum.
            move => k1.
            apply sum_n_plus.
        assert
            (sum_n
                (λ k1 : nat,
                sum_n
                    (λ k2 : nat,
                        plus
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vf k1))
                            (scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vg k2))
                ) maxg
            ) maxf
            =
            plus
                (sum_n
                    (λ k1 : nat,
                    sum_n
                        (λ k2 : nat,
                            scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vf k1)
                    ) maxg
                ) maxf)
                (sum_n
                    (λ k1 : nat,
                    sum_n
                        (λ k2 : nat,
                            scal
                            (real (μ (λ x : X, wf x = k1 ∧ wg x = k2)))
                            (vg k2)
                    ) maxg
                ) maxf)
            ) as Rwrt.
            rewrite <-sum_n_plus.
            apply sum_n_ext_loc => k1 //.
        rewrite Rwrt.
        clear Rwrt Eqsum.
        (* Etape mathématiquement importante ! *)
        setoid_rewrite sum_n_switch at 2.
        assert
            (sum_n
                (λ j : nat,
                sum_n (λ i : nat, scal (real (μ (λ x : X, wf x = i ∧ wg x = j))) (vg j))
            maxf) maxg
            =
            sum_n
                (λ k2 : nat,
                scal
                    (sum_n (λ k1 : nat, (real (μ (λ x : X, wf x = k1 ∧ wg x = k2))))
                    maxf)
                    (vg k2)
            ) maxg
            ) as Eqsum.
            apply sum_n_ext => n.
            rewrite sum_n_scal_r => //.
        rewrite Eqsum; clear Eqsum.
        assert
            (sum_n
                (λ k1 : nat,
                sum_n (λ k2 : nat, scal (real (μ (λ x : X, wf x = k1 ∧ wg x = k2))) (vf k1))
            maxg) maxf
            =
            sum_n
                (λ k1 : nat,
                scal
                    (sum_n (λ k2 : nat, (real (μ (λ x : X, wf x = k1 ∧ wg x = k2))))
                    maxg)
                    (vf k1)
            ) maxf
            ) as Eqsum.
            apply sum_n_ext => n.
            rewrite sum_n_scal_r => //.
        rewrite Eqsum; clear Eqsum.
        assert
            (∀ k1 k2 : nat, k1 ≤ maxf -> k2 ≤ maxg ->
                measurable gen (λ x : X, wf x = k1 ∧ wg x = k2)
            ) as measurable_inter_fg.
                move => k1 k2 Hk1 Hk2.
                apply measurable_inter.
                1, 2 : apply [axf3, axg3] => //.
        congr plus; apply sum_n_ext_loc.
            replace (val sf_f) with vf by rewrite Eqf => //.
            move => k1 Hk1.
            case (le_lt_or_eq k1 maxf) => //.
                move => Hk1'.
                congr scal.
                replace (which sf_f) with wf by rewrite Eqf => //.
                rewrite sum_n_sum_Rbar.
                    all : swap 1 2.
                    move => k2 Hk2.
                    assert
                        (Rbar_le
                            (μ (λ x : X, wf x = k1 ∧ wg x = k2))
                            (μ (λ x : X, wf x = k1))
                        ) as inter_le_f.
                        apply measure_le.
                        apply measurable_inter_fg => //.
                        apply axf3 => //.
                        easy.
                    pose fin_μ_f := axf4 k1 Hk1'; clearbody fin_μ_f.
                    unfold is_finite in fin_μ_f; rewrite <-fin_μ_f in inter_le_f.
                    unfold real in inter_le_f.
                    unfold is_finite, real.
                    case_eq (μ (λ x : X, wf x = k1 ∧ wg x = k2)) => //.
                        move => Abs_μ; apply False_ind.
                        rewrite Abs_μ in inter_le_f => //.
                        move => Abs_μ; apply False_ind.
                        pose Ge0μ := meas_ge_0 gen μ (λ x : X, wf x = k1 ∧ wg x = k2); clearbody Ge0μ.
                        rewrite Abs_μ in Ge0μ => //.
                    rewrite (measure_decomp_finite gen μ (fun (x : X) => wf x = k1) maxg (fun k2 => (fun (x : X) => wg x = k2))) => //.
                        apply axf3 => //.
                        move => x; exists (wg x); split => //.
                        move => n p x _ _ -> //.
                move => ->.
                rewrite axf1; do 2 rewrite scal_zero_r => //.
            replace (val sf_g) with vg by rewrite Eqg => //.
            move => k2 Hk2.
            case (le_lt_or_eq k2 maxg) => //.
                move => Hk2'.
                congr scal.
                replace (which sf_g) with wg by rewrite Eqg => //.
                rewrite sum_n_sum_Rbar.
                    all : swap 1 2.
                    move => k1 Hk1.
                    assert
                        (Rbar_le
                            (μ (λ x : X, wf x = k1 ∧ wg x = k2))
                            (μ (λ x : X, wg x = k2))
                        ) as inter_le_g.
                        apply measure_le.
                        apply measurable_inter_fg => //.
                        apply axg3 => //.
                        easy.
                    pose fin_μ_g := axg4 k2 Hk2'; clearbody fin_μ_g.
                    unfold is_finite in fin_μ_g; rewrite <-fin_μ_g in inter_le_g.
                    unfold real in inter_le_g.
                    unfold is_finite, real.
                    case_eq (μ (λ x : X, wf x = k1 ∧ wg x = k2)) => //.
                        move => Abs_μ; apply False_ind.
                        rewrite Abs_μ in inter_le_g => //.
                        move => Abs_μ; apply False_ind.
                        pose Ge0μ := meas_ge_0 gen μ (λ x : X, wf x = k1 ∧ wg x = k2); clearbody Ge0μ.
                        rewrite Abs_μ in Ge0μ => //.
                    rewrite (measure_decomp_finite gen μ (fun (x : X) => wg x = k2) maxf (fun k1 => (fun (x : X) => wf x = k1))) => //.
                        rewrite (sum_Rbar_ext maxf (λ n : nat, μ (λ x : X, wg x = k2 ∧ wf x = n)) (λ k : nat, μ (λ x : X, wf x = k ∧ wg x = k2))).
                        all : swap 1 2.
                        move => i Hi.
                        apply measure_ext => x.
                        split; case => //.
                        reflexivity.
                        apply axg3 => //.
                        move => x; exists (wf x); split => //.
                        move => n p x _ _ -> //.
                move => ->.
                rewrite axg1; do 2 rewrite scal_zero_r => //.
    Qed.

End BInt_sf_plus.

Section BInt_sf_scal.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : cette fois c'est nécessairement un R-module
    (en fait je pense qu'on pourrait prendre un surcorps de R mais je ne vois pas comment
    formaliser celà simplement) *)
    Context {E : NormedModule R_AbsRing}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Open Scope R_scope.
    Open Scope nat_scope.
    Open Scope sf_scope.

    Lemma BInt_sf_scal_aux :
        ∀ a : R_AbsRing, ∀ sf : simpl_fun E gen,
            BInt_sf μ (a ⋅ sf) = (a ⋅ (BInt_sf μ sf))%hy.
    Proof.
        move => a sf.
        unfold BInt_sf.
        case_eq sf => wf vf maxf axf1 axf2 axf3 Eqsf; rewrite <-Eqsf.
        rewrite <-sum_n_scal_l.
        replace (max_which (a ⋅ sf)) with (max_which sf)
            by rewrite Eqsf => //.
        apply sum_n_ext => k.
        unfold nth_carrier.
        replace (which (a ⋅ sf)) with (which sf)
            by rewrite Eqsf => //.
        replace (val (a ⋅ sf) k) with (scal a (val sf k))
            by rewrite Eqsf => //.
        do 2 rewrite scal_assoc.
        replace mult with Rmult by easy.
        rewrite Raxioms.Rmult_comm.
        replace (@mult R_AbsRing) with Rmult by easy.
        reflexivity.
    Qed.

End BInt_sf_scal.

Section BInt_sf_linearity.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : cette fois c'est nécessairement un R-module
    (en fait je pense qu'on pourrait prendre un surcorps de R mais je ne vois pas comment
    formaliser celà simplement) *)
    Context {E : NormedModule R_AbsRing}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Open Scope R_scope.
    Open Scope nat_scope.
    Open Scope sf_scope.

    Lemma BInt_sf_lin_aux {sf sg : simpl_fun E gen} :
        ∀ a b : R_AbsRing, integrable_sf μ sf -> integrable_sf μ sg ->
            BInt_sf μ (a ⋅ sf + b ⋅ sg)
            = ((a ⋅ (BInt_sf μ sf)) + (b ⋅ (BInt_sf μ sg)))%hy.
    Proof.
        move => a b isf isg.
        do 2 rewrite <-BInt_sf_scal_aux.
        rewrite BInt_sf_plus_aux => //.
        1, 2 : apply integrable_sf_scal => //.
    Qed.

End BInt_sf_linearity.

Lemma norm_scal_eq {E : NormedModule R_AbsRing} :
    ∀ r : R, ∀ x : E, ‖ r ⋅ x ‖ = | r | ⋅ ‖ x ‖.
Proof.
    move => a x.
    apply RIneq.Rle_antisym.
        unfold scal at 2 => /=.
        exact (norm_scal a x).
        case (RIneq.Req_dec a 0).
            move => ->.
            rewrite abs_zero; do 2 rewrite scal_zero_l; rewrite norm_zero.
            apply RIneq.Rle_refl.
        (* case (RIneq.Req_dec (‖x‖) 0).
            move => Hx _.
            rewrite Hx scal_zero_r.
            apply norm_ge_0.
        move => xNeq0 aNeq0. *)
        move => aNeq0.
        apply RIneq.Rmult_le_reg_l with (|/a|)%R.
        apply Rabs_pos_lt.
        apply RIneq.Rinv_neq_0_compat => //.
        replace ((| / a |) * ((| a |) ⋅ (‖ x ‖)))%R
            with ((| / a |) ⋅ ((| a |) ⋅ (‖ x ‖)))%hy
            by unfold scal at 1 => //.
        rewrite scal_assoc.
        unfold abs at 1 2 => /=.
        rewrite <-Rabs_mult.
        rewrite <-RIneq.Rinv_l_sym.
        unfold scal at 1 => /=.
        unfold mult => /=.
        rewrite (Rabs_right _ (RIneq.Rle_ge _ _ RIneq.Rle_0_1)).
        rewrite Raxioms.Rmult_1_l.
        replace x with (/a ⋅ (a ⋅ x)) at 1.
            3 : assumption.
            2 : rewrite scal_assoc.
            2 : rewrite <-RIneq.Rinv_l_sym => //.
            2 : rewrite scal_one => //.
        apply (norm_scal (/a) (a⋅x)).
Qed.

Section BInt_sf_norm.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : cette fois c'est nécessairement un R-module
    (en fait je pense qu'on pourrait prendre un surcorps de R mais je ne vois pas comment
    formaliser celà simplement) *)
    Context {E : NormedModule R_AbsRing}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Open Scope R_scope.
    Open Scope nat_scope.
    Open Scope sf_scope.

    Lemma norm_Bint_sf_le :
        ∀ sf : simpl_fun E gen,
            (‖ BInt_sf μ sf ‖%hy <= BInt_sf μ (‖ sf ‖))%R.
    Proof.
        move => sf;
            case_eq sf => vf wf maxf axf1 axf2 axf3 Eqf;
            rewrite <-Eqf.
        unfold BInt_sf.
        replace (max_which sf) with maxf by rewrite Eqf => //.
        replace (max_which (‖ sf ‖)) with maxf at 1 by rewrite Eqf => //.
        rewrite (sum_n_ext_loc _ ((λ n : nat, | real (μ (nth_carrier sf n)) | ⋅ (‖ val sf n ‖)%hy)))%hy.
            all : swap 1 2.
            rewrite Eqf => /=.
            unfold abs => /= n Hn.
            case: (le_lt_or_eq n maxf) => // Hn'; clear Hn.
            rewrite Rabs_pos_eq => //.
            unfold nth_carrier => /=.
            pose Le0μn := meas_ge_0 _ μ (λ x : X, vf x = n); clearbody Le0μn.
            case_eq (μ (λ x : X, vf x = n)).
                move => r Eqr; rewrite Eqr in Le0μn => //.
                move => _; simpl; apply RIneq.Rle_refl.
                move => Abs; rewrite Abs in Le0μn => //.
            setoid_rewrite Hn' at 2 4.
            replace (wf maxf) with (@zero E) at 2 3.
            rewrite norm_zero; do 2 rewrite scal_zero_r => //.
        rewrite (sum_n_ext _ (λ n : nat, ‖ (real (μ (nth_carrier sf n))) ⋅ (val sf n) ‖)%hy).
            all : swap 1 2.
            move => n.
            rewrite norm_scal_eq => //.
        apply: norm_sum_n_m.
    Qed.

End BInt_sf_norm.

Section BInt_well_defined.

    (* espace de départ *)
    Context  {X : Set}.
    (* espace d'arrivé : cette fois c'est nécessairement un R-module
    (en fait je pense qu'on pourrait prendre un surcorps de R mais je ne vois pas comment
    formaliser celà simplement) *)
    Context {E : NormedModule R_AbsRing}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Lemma BInt_sf_zero :
        ∀ sf : simpl_fun E gen,
            (∀ x : X, fun_sf sf x = zero)
            -> BInt_sf μ sf = zero.
    Proof.
        move => sf.
        case_eq sf => wf vf maxf axf1 axf2 axf3 Eqf; rewrite <-Eqf.
        unfold fun_sf => Hf.
        unfold BInt_sf.
        rewrite (sum_n_ext_loc _ (fun (n : nat) => zero)).
            induction max_which.
                rewrite sum_O => //.
                rewrite sum_Sn plus_zero_r; apply IHn.
        move => n Hn.
        unfold nth_carrier.
        replace (which sf) with wf by rewrite Eqf => //.
        replace (max_which sf) with maxf in Hn
            by rewrite Eqf => //.
        case: (le_lt_or_eq n maxf) => // Hn'.
            (* pose Hμn := axf4 n Hn'; clearbody Hμn; unfold is_finite in Hμn. *)
            pose Le0μn := meas_ge_0 _ μ (λ x : X, wf x = n); clearbody Le0μn.
            case: (Rbar_le_cases _ Le0μn).
                (* cas où le support est de mesure nulle *)
                move => ->.
                rewrite scal_zero_l => //.
                (* cas où le support est habité *)
                case.
                    case => r [Lt0r Eqr].
                    assert (Rbar_lt 0%R (μ (λ x : X, wf x = n))) as Lt0μn.
                        rewrite Eqr.
                        unfold Rbar_lt => //.
                    case: (measure_gt_0_exists _ _ _ Lt0μn) => x <-.
                    replace (which sf) with wf in Hf by rewrite Eqf => //.
                    rewrite Hf scal_zero_r => //.
                    move => -> /=; rewrite scal_zero_l => //.
            replace (val sf) with vf by rewrite Eqf => //.
            rewrite Hn'.
            rewrite axf1 scal_zero_r => //.
    Qed.

    Lemma BInt_sf_ext {sf sf' : simpl_fun E gen} :
        integrable_sf μ sf -> integrable_sf μ sf' ->
            (∀ x : X, fun_sf sf x = fun_sf sf' x) ->
            BInt_sf μ sf = BInt_sf μ sf'.
    Proof.
        move => isf isf' Hsfsf'.
        pose δ := (sf + (opp one) ⋅ sf')%sf.
        assert (∀ x : X, fun_sf δ x = zero) as δNul.
            move => x; unfold δ.
            rewrite fun_sf_plus fun_sf_scal.
            rewrite scal_opp_l scal_one.
            rewrite <-Hsfsf'; rewrite plus_opp_r => //.
            assert ((BInt_sf μ sf) + (opp one) ⋅ (BInt_sf μ sf') = (BInt_sf μ sf') + (opp one) ⋅ (BInt_sf μ sf'))%hy as Subgoal.
                rewrite <-BInt_sf_scal_aux at 1.
                rewrite <-BInt_sf_plus_aux at 1.
                fold δ; rewrite BInt_sf_zero.
                rewrite scal_opp_l scal_one plus_opp_r => //.
                assumption.
            3 : apply plus_reg_r with ((opp one) ⋅ (BInt_sf μ sf'))%hy => //.
            2 : apply integrable_sf_scal.
            1, 2 : assumption.
    Qed.

End BInt_well_defined.


(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect.
From Coq.Unicode Require Import Utf8.
Require Import ZArith Setoid Morphisms CMorphisms CRelationClasses.
Require Import xseq oseq.
Require Psatz.
From mathcomp Require Import word_ssrZ.

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

Local Open Scope Z_scope.

(* -------------------------------------------------------------------- *)
Module FinIsCount.
Section FinIsCount.
Variable (T : eqType) (enum : seq T) (A : Finite.axiom enum).

Definition pickle (x : T) :=
  seq.index x enum.

Definition unpickle (n : nat) :=
  nth None [seq some x | x <- enum] n.

Definition pickleK : pcancel pickle unpickle.
Proof.
move=> x; have xE: x \in enum by apply/count_memPn; rewrite (A x).
by rewrite /pickle /unpickle (nth_map x) ?(nth_index, index_mem).
Qed.
End FinIsCount.
End FinIsCount.

Class eqTypeC (T:Type) :=
  { beq : T -> T -> bool
  ; ceqP: Equality.axiom beq }.

Section EqType.

Context {T:Type} {ceqT : eqTypeC T}.
Definition ceqT_eqMixin := Equality.Mixin ceqP.
Definition ceqT_eqType  := Eval hnf in EqType T ceqT_eqMixin.

End EqType.

Notation "x == y ::> T" := (eq_op (T:= @ceqT_eqType T _) x y)
  (at level 70, y at next level) : bool_scope.

Notation "x == y ::>" := (eq_op (T:= @ceqT_eqType _ _) x y)
  (at level 70, y at next level) : bool_scope.

Class finTypeC (T:Type) :=
  { _eqC   :> eqTypeC T
  ; cenum  : seq T
  ; cenumP : @Finite.axiom ceqT_eqType cenum
  }.

Section FinType.

Context `{cfinT:finTypeC}.

Definition cfinT_choiceMixin :=
  PcanChoiceMixin (FinIsCount.pickleK cenumP).
Definition cfinT_choiceType :=
  Eval hnf in ChoiceType ceqT_eqType cfinT_choiceMixin.

Definition cfinT_countMixin :=
  PcanCountMixin (FinIsCount.pickleK cenumP).
Definition cfinT_countType :=
  Eval hnf in @Countable.pack T cfinT_countMixin cfinT_choiceType _ (fun x => x).

Definition cfinT_finMixin :=
  @Finite.EnumMixin cfinT_countType _ cenumP.
Definition cfinT_finType :=
  Eval hnf in
    (@Finite.pack T ceqT_eqMixin cfinT_finMixin cfinT_choiceType _ (fun x => x) _ (fun x => x)).

Lemma mem_cenum : cenum =i ceqT_eqType.
Proof.
  move=> x. rewrite -has_pred1 has_count. by rewrite cenumP.
Qed.

End FinType.

Module FinMap.

Section Section.

Context `{cfinT:finTypeC} (U:Type).

(* Map from T -> U *)

Definition map := @finfun_of cfinT_finType (fun _ => U) (Phant _).

Definition of_fun :=
  @FinfunDef.finfun cfinT_finType (fun _ => U).

Definition set (m:map) (x: T) (y:U) : map :=
  of_fun (fun z : T => if z == x ::> then y else m z).

End Section.

End FinMap.

(* -------------------------------------------------------------------- *)
Lemma reflect_inj (T:eqType) (U:Type) (f:T -> U) a b :
  injective f -> reflect (a = b) (a == b) -> reflect (f a = f b) (a == b).
Proof. by move=> hinj heq; apply: (iffP heq) => [| /hinj ] ->. Qed.

(* -------------------------------------------------------------------- *)
(* Missing Instance in ssreflect for setoid rewrite                     *)

#[global]
Instance and3_impl_morphism :
  Proper (Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl) and3 | 1.
Proof. by move=> ?? h1 ?? h2 ?? h3 [/h1 ? /h2 ? /h3 ?]. Qed.

#[global]
Instance and3_iff_morphism :
  Proper (iff ==> iff ==> iff ==> iff) and3.
Proof. by move=> ?? h1 ?? h2 ?? h3; split => -[] /h1 ? /h2 ? /h3. Qed.

#[global]
Instance and4_impl_morphism :
  Proper (Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl) and4 | 1.
Proof. by move=> ?? h1 ?? h2 ?? h3 ?? h4 [/h1 ? /h2 ? /h3 ? /h4 ?]. Qed.

#[global]
Instance and4_iff_morphism :
  Proper (iff ==> iff ==> iff ==> iff ==> iff) and4.
Proof. by move=> ?? h1 ?? h2 ?? h3 ?? h4; split => -[] /h1 ? /h2 ? /h3 ? /h4. Qed.

#[global]
Instance and5_impl_morphism :
  Proper (Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl) and5 | 1.
Proof. by move=> ?? h1 ?? h2 ?? h3 ?? h4 ?? h5 [/h1 ? /h2 ? /h3 ? /h4 ? /h5]. Qed.

#[global]
Instance and5_iff_morphism :
  Proper (iff ==> iff ==> iff ==> iff ==> iff ==> iff) and5.
Proof. by move=> ?? h1 ?? h2 ?? h3 ?? h4 ?? h5; split => -[] /h1 ? /h2 ? /h3 ? /h4 ? /h5 ?. Qed.

(* ** Result monad
 * -------------------------------------------------------------------- *)

Variant result (E : Type) (A : Type) : Type :=
| Ok of A
| Error of E.

Arguments Error {E} {A} s.

Definition is_ok (E A:Type) (r:result E A) := if r is Ok a then true else false.

Lemma is_ok_ok (E A:Type) (a:A) : is_ok (Ok E a).
Proof. done. Qed.
#[global]
Hint Resolve is_ok_ok : core.

Lemma is_okP (E A:Type) (r:result E A) : reflect (exists (a:A), r = Ok E a) (is_ok r).
Proof.
  case: r => /=; constructor; first by eauto.
  by move=> [].
Qed.

Section ResultEqType.

Variable E A : eqType.

Definition result_eq (r1 r2: result E A): bool :=
  match r1, r2 with
  | Ok a1, Ok a2 => a1 == a2
  | Error e1, Error e2 => e1 == e2
  | _, _ => false
  end.

Lemma result_eqP : Equality.axiom result_eq.
Proof.
  case=> [a1|e1] [a2|e2] /=; try (by apply: ReflectF);
  by apply: (equivP eqP);split=>[|[]] ->.
Qed.

Canonical result_eqMixin := EqMixin result_eqP.
Canonical result_eqType := Eval hnf in EqType (result E A) result_eqMixin.

End ResultEqType.

Module Result.

Definition apply eT aT rT (f : aT -> rT) (x : rT) (u : result eT aT) :=
  if u is Ok y then f y else x.

Definition bind eT aT rT (f : aT -> result eT rT) g :=
  match g with
  | Ok x    => f x
  | Error s => Error s
  end.

Definition map eT aT rT (f : aT -> rT) := bind (fun x => Ok eT (f x)).
Definition default eT aT := @apply eT aT aT (fun x => x).

End Result.

Definition o2r eT aT (e : eT) (o : option aT) :=
  match o with
  | None   => Error e
  | Some x => Ok eT x
  end.

Notation rapp  := Result.apply.
Notation rdflt := Result.default.
Notation rbind := Result.bind.
Notation rmap  := Result.map.
Notation ok    := (@Ok _).

Notation "m >>= f" := (rbind f m) (at level 25, left associativity).
Notation "'Let' x ':=' m 'in' body" := (m >>= (fun x => body)) (x name, at level 25).
Notation "'Let:' x ':=' m 'in' body" := (m >>= (fun x => body)) (x strict pattern, at level 25).
Notation "m >> n" := (rbind (λ _, n) m) (at level 30, right associativity, n at next level).

Lemma bindA eT aT bT cT (f : aT -> result eT bT) (g: bT -> result eT cT) m:
  m >>= f >>= g = m >>= (fun a => f a >>= g).
Proof. case:m => //=. Qed.

Lemma bind_eq eT aT rT (f1 f2 : aT -> result eT rT) m1 m2 :
   m1 = m2 -> f1 =1 f2 -> m1 >>= f1 = m2 >>= f2.
Proof. move=> <- Hf; case m1 => //=. Qed.

Definition ok_inj {E A} {a a': A} (H: Ok E a = ok a') : a = a' :=
  let 'Logic.eq_refl := H in Logic.eq_refl.

Definition Error_inj {E A} (a a': E) (H: @Error E A a = Error a') : a = a' :=
  let 'Logic.eq_refl := H in Logic.eq_refl.

Definition assert E (b: bool) (e: E) : result E unit :=
  if b then ok tt else Error e.

Lemma assertP E b e u :
  @assert E b e = ok u → b.
Proof. by case: b. Qed.

Arguments assertP {E b e u} _.

Variant error :=
 | ErrOob | ErrAddrUndef | ErrAddrInvalid | ErrStack | ErrType.

Scheme Equality for error.

Lemma error_beqP : Equality.axiom error_beq.
Proof.
  move=> e1 e2;case Heq: error_beq;constructor.
  + by apply: internal_error_dec_bl.
  by move=> /internal_error_dec_lb;rewrite Heq.
Qed.

Canonical error_eqMixin := EqMixin error_beqP.
Canonical error_eqType := Eval hnf in EqType error error_eqMixin.

Definition exec t := result error t.

Definition type_error {t} := @Error _ t ErrType.
Definition undef_error {t} := @Error error t ErrAddrUndef.

Lemma bindW {T U} (v : exec T) (f : T -> exec U) r :
  v >>= f = ok r -> exists2 a, v = ok a & f a = ok r.
Proof. by case E: v => [a|//] /= <-; exists a. Qed.

Lemma rbindP eT aT rT (e:result eT aT) (body:aT -> result eT rT) v (P:Type):
  (forall z, e = ok z -> body z = Ok _ v -> P) ->
  e >>= body = Ok _ v -> P.
Proof. by case: e=> //= a H /H H';apply H'. Qed.

Ltac t_rbindP := do? (apply: rbindP => ??).

Ltac t_xrbindP :=
  match goal with
  | [ |- Result.bind _ _ = Ok _ _ -> _ ] =>
      apply: rbindP; t_xrbindP
  | [ |- Result.map _ _ = Ok _ _ -> _ ] =>
      rewrite /rmap; t_xrbindP
  | [ |- assert _ _ = Ok _ _ -> _ ] =>
      move=> /assertP; t_xrbindP
  | [ |- unit -> _ ] =>
      case; t_xrbindP
  | [ |- ok _ = ok _ -> _ ] =>
      case; t_xrbindP
  | [ |- forall h, _ ] =>
      let hh := fresh h in move=> hh; t_xrbindP; move: hh
  | _ => idtac
  end.

Ltac clarify :=
  repeat match goal with
  | H : ?a = ?b |- _ => subst a || subst b
  | H : ok _ = ok _ |- _ => apply ok_inj in H
  | H : Some _ = Some _ |- _ => move: H => /Some_inj H
  | H : ?a = _, K : ?a = _ |- _ => rewrite H in K
  end.

Lemma Let_Let {eT A B C} (a:result eT A) (b:A -> result eT B) (c: B -> result eT C) :
  ((a >>= b) >>= c) = a >>= (fun a => b a >>= c).
Proof. by case: a. Qed.

Definition mapM eT aT bT (f : aT -> result eT bT)  : seq aT → result eT (seq bT) :=
  fix mapM xs :=
  match xs with
  | [::] =>
      Ok eT [::]
  | [:: x & xs] =>
      f x >>= fun y =>
      mapM xs >>= fun ys =>
      Ok eT [:: y & ys]
  end.

Lemma mapM_cons aT eT bT x xs y ys (f : aT -> result eT bT):
  f x = ok y /\ mapM f xs = ok ys
  <-> mapM f (x :: xs) = ok (y :: ys).
Proof.
  split.
  by move => [] /= -> ->.
  by simpl; t_xrbindP => y0 -> h0 -> -> ->.
Qed.

Lemma map_ext aT bT f g m :
  (forall a, List.In a m -> f a = g a) ->
  @map aT bT f m = map g m.
Proof.
elim: m => //= a m ih ext.
rewrite ext; [ f_equal | ]; eauto.
Qed.

Lemma mapM_ext eT aT bT (f1 f2: aT → result eT bT) (m: seq aT) :
  (∀ a, List.In a m → f1 a = f2 a) →
  mapM f1 m = mapM f2 m.
Proof.
  elim: m => // a m ih ext /=.
  rewrite (ext a); last by left.
  case: (f2 _) => //= b; rewrite ih //.
  by move => ? h; apply: ext; right.
Qed.

Lemma eq_mapM eT (aT: eqType) bT (f1 f2: aT -> result eT bT) (l:list aT) :
  (forall a, a \in l -> f1 a = f2 a) ->
  mapM f1 l = mapM f2 l.
Proof.
  elim: l => //= a l hrec hf; rewrite hf ? hrec //.
  + by move=> ? h; apply/hf; rewrite in_cons h orbT.
  by apply mem_head.
Qed.

Lemma size_mapM eT aT bT f xs ys :
  @mapM eT aT bT f xs = ok ys ->
  size xs = size ys.
Proof.
elim: xs ys.
- by move => ys [<-].
move => x xs ih ys /=; case: (f _) => //= y.
by case: (mapM f xs) ih => //= ys' ih [] ?; subst; rewrite (ih _ erefl).
Qed.

Local Close Scope Z_scope.

Lemma mapM_nth eT aT bT f xs ys d d' n :
  @mapM eT aT bT f xs = ok ys ->
  n < size xs ->
  f (nth d xs n) = ok (nth d' ys n).
Proof.
elim: xs ys n.
- by move => ys n [<-].
move => x xs ih ys n /=; case h: (f _) => [ y | ] //=.
case: (mapM f xs) ih => //= ys' /(_ _ _ erefl) ih [] <- {ys}.
by case: n ih => // n /(_ n).
Qed.

Local Open Scope Z_scope.

Lemma mapM_onth eT aT bT (f: aT → result eT bT) (xs: seq aT) ys n x :
  mapM f xs = ok ys →
  onth xs n = Some x →
  ∃ y, onth ys n = Some y ∧ f x = ok y.
Proof.
move => ok_ys.
case: (leqP (size xs) n) => hsz; first by rewrite (onth_default hsz).
elim: xs ys ok_ys n hsz.
- by move => ys [<-].
move => y xs ih ys' /=; t_xrbindP => z ok_z ys ok_ys <- [| n ] hsz /= ok_y.
- by exists z; case: ok_y => <-.
exact: (ih _ ok_ys n hsz ok_y).
Qed.

Lemma mapM_onth' eT aT bT (f: aT → result eT bT) (xs: seq aT) ys n y :
  mapM f xs = ok ys →
  onth ys n = Some y →
  ∃ x, onth xs n = Some x ∧ f x = ok y.
Proof.
move => ok_ys.
case: (leqP (size ys) n) => hsz; first by rewrite (onth_default hsz).
elim: xs ys ok_ys n hsz.
- by move => ys [<-].
move => x xs ih ys' /=; t_xrbindP => z ok_z ys ok_ys <- [| n ] hsz /= ok_y.
- by exists x; case: ok_y => <-.
exact: (ih _ ok_ys n hsz ok_y).
Qed.

Lemma mapMP {eT} {aT bT: eqType} (f: aT -> result eT bT) (s: seq aT) (s': seq bT) y:
  mapM f s = ok s' ->
  reflect (exists2 x, x \in s & f x = ok y) (y \in s').
Proof.
elim: s s' => /= [s' [] <-|x s IHs s']; first by right; case.
apply: rbindP=> y0 Hy0.
apply: rbindP=> ys Hys []<-.
have IHs' := (IHs _ Hys).
rewrite /= in_cons eq_sym; case Hxy: (y0 == y).
  by left; exists x; [rewrite mem_head | rewrite -(eqP Hxy)].
apply: (iffP IHs')=> [[x' Hx' <-]|[x' Hx' Dy]].
  by exists x'; first by apply: predU1r.
rewrite -Dy.
case/predU1P: Hx'=> [Hx|].
+ exfalso.
  move: Hxy=> /negP Hxy.
  apply: Hxy.
  rewrite Hx Hy0 in Dy.
  by move: Dy=> [] ->.
+ by exists x'.
Qed.

Lemma mapM_In {aT bT eT} (f: aT -> result eT bT) (s: seq aT) (s': seq bT) x:
  mapM f s = ok s' ->
  List.In x s -> exists y, List.In y s' /\ f x = ok y.
Proof.
elim: s s'=> // a l /= IH s'.
apply: rbindP=> y Hy.
apply: rbindP=> ys Hys []<-.
case.
+ by move=> <-; exists y; split=> //; left.
+ move=> Hl; move: (IH _ Hys Hl)=> [y0 [Hy0 Hy0']].
  by exists y0; split=> //; right.
Qed.

Lemma mapM_In' {aT bT eT} (f: aT -> result eT bT) (s: seq aT) (s': seq bT) y:
  mapM f s = ok s' ->
  List.In y s' -> exists2 x, List.In x s & f x = ok y.
Proof.
elim: s s'.
+ by move => _ [<-].
move => a s ih s'' /=; t_xrbindP => b ok_b s' rec <- {s''} /=.
case.
+ by move=> <-; exists a => //; left.
by move => h; case: (ih _ rec h) => x hx ok_y; eauto.
Qed.

Lemma mapM_map {aT bT cT eT} (f: aT → bT) (g: bT → result eT cT) (xs: seq aT) :
  mapM g (map f xs) = mapM (g \o f) xs.
Proof. by elim: xs => // x xs ih /=; case: (g (f x)) => // y /=; rewrite ih. Qed.

Lemma mapM_cat  {eT aT bT} (f: aT → result eT bT) (s1 s2: seq aT) :
  mapM f (s1 ++ s2) = Let r1 := mapM f s1 in Let r2 := mapM f s2 in ok (r1 ++ r2).
Proof.
  elim: s1 s2; first by move => s /=; case (mapM f s).
  move => a s1 ih s2 /=.
  case: (f _) => // b; rewrite /= ih{ih}.
  case: (mapM f s1) => // bs /=.
  by case: (mapM f s2).
Qed.

Corollary mapM_rcons  {eT aT bT} (f: aT → result eT bT) (s: seq aT) (a: aT) :
  mapM f (rcons s a) = Let r1 := mapM f s in Let r2 := f a in ok (rcons r1 r2).
Proof. by rewrite -cats1 mapM_cat /=; case: (f a) => // b; case: (mapM _ _) => // bs; rewrite /= cats1. Qed.

Lemma mapM_Forall2 {eT aT bT} (f: aT → result eT bT) (s: seq aT) (s': seq bT) :
  mapM f s = ok s' →
  List.Forall2 (λ a b, f a = ok b) s s'.
Proof.
  elim: s s'.
  - by move => _ [] <-; constructor.
  move => a s ih s'' /=; t_xrbindP => b ok_b s' /ih{ih}ih <-{s''}.
  by constructor.
Qed.

Lemma mapM_factorization {aT bT cT eT fT} (f: aT → result fT bT) (g: aT → result eT cT) (h: bT → result eT cT) xs ys:
  (∀ a b, f a = ok b → g a = h b) →
  mapM f xs = ok ys →
  mapM g xs = mapM h ys.
Proof.
  move => E.
  elim: xs ys; first by case.
  by move => x xs ih ys' /=; t_xrbindP => y /E -> ys /ih -> <-.
Qed.

Lemma mapM_assoc {eT} {aT:eqType} {bT cT} (f : aT * bT -> result eT (aT * cT)) l1 l2 a b :
  (forall x y, f x = ok y -> x.1 = y.1) ->
  mapM f l1 = ok l2 ->
  assoc l1 a = Some b ->
  exists2 c, f (a, b) = ok (a, c) & assoc l2 a = Some c.
Proof.
  move=> hfst.
  elim: l1 l2 => //.
  move=> [a' b'] l1 ih /=.
  t_xrbindP=> _ [a'' c] h l2 /ih{ih}ih <- /=.
  have /= ? := hfst _ _ h; subst a''.
  case: eqP => [->|_]; last by apply ih.
  move=> [<-].
  by exists c.
Qed.

Lemma mapM_assoc' {eT} {aT:eqType} {bT cT} (f : aT * bT -> result eT (aT * cT)) l1 l2 a c :
  (forall x y, f x = ok y -> x.1 = y.1) ->
  mapM f l1 = ok l2 ->
  assoc l2 a = Some c ->
  exists2 b, f (a, b) = ok (a, c) & assoc l1 a = Some b.
Proof.
  move=> hfst.
  elim: l2 l1 => //.
  move=> [a' c'] l2 ih [//|[a'' b] l1] /=.
  t_xrbindP=> y h l2' hmap ??; subst y l2'.
  have /= ? := hfst _ _ h; subst a''.
  case: eqP => [->|_]; last by apply ih.
  move=> [<-].
  by exists b.
Qed.

Section FOLDM.

  Context (eT aT bT:Type) (f:aT -> bT -> result eT bT).

  Fixpoint foldM (acc : bT) (l : seq aT) :=
    match l with
    | [::]         => Ok eT acc
    | [:: a & la ] => f a acc >>= fun acc => foldM acc la
    end.

  Fixpoint foldrM (acc : bT) (l : seq aT) :=
    match l with
    | [::]         => Ok eT acc
    | [:: a & la ] => foldrM acc la >>= f a
    end.

End FOLDM.

Section FOLD2.

  Variable A B E R:Type.
  Variable e: E.
  Variable f : A -> B -> R -> result E R.

  Fixpoint fold2 (la:seq A) (lb: seq B) r :=
    match la, lb with
    | [::]  , [::]   => Ok E r
    | a::la, b::lb =>
      f a b r >>= (fold2 la lb)
    | _     , _      => Error e
    end.

  Lemma size_fold2 xs ys x0 v:
    fold2 xs ys x0 = ok v -> size xs = size ys.
  Proof.
    by elim : xs ys x0 => [|x xs ih] [|y ys] x0 //= ; t_xrbindP => // t _ /ih ->.
  Qed.

End FOLD2.

(* ---------------------------------------------------------------- *)
(* ALLM *)
Section ALLM.
  Context (A E: Type) (check: A → result E unit) (m: seq A).
  Definition allM := foldM (λ a _, check a) tt m.

  Lemma allMP a : List.In a m → allM = ok tt → check a = ok tt.
  Proof.
    rewrite /allM.
    by elim: m => // a' m' ih /= [ ->{a'} | /ih ]; t_xrbindP.
  Qed.

End ALLM.
Arguments allMP {A E check m a} _ _.

(* Forall3 *)
(* -------------------------------------------------------------- *)

Inductive Forall3 (A B C : Type) (R : A -> B -> C -> Prop) : seq A -> seq B -> seq C -> Prop :=
| Forall3_nil : Forall3 R [::] [::] [::]
| Forall3_cons : forall a b c la lb lc, R a b c -> Forall3 R la lb lc -> Forall3 R (a :: la) (b :: lb) (c :: lc).

Section MAP2.

  Variable A B E R:Type.
  Variable e: E.

  Variable f : A -> B -> result E R.

  Fixpoint mapM2 (la:seq A) (lb: seq B) :=
    match la, lb with
    | [::]  , [::]   => Ok E [::]
    | a::la, b::lb =>
      Let c := f a b in
      Let lc := mapM2 la lb in
      ok (c::lc)
    | _     , _      => Error e
    end.

  Lemma size_mapM2 ma mb mr :
    mapM2 ma mb = ok mr ->
    size ma = size mb /\ size ma = size mr.
  Proof.
    elim: ma mb mr.
    + by move=> [|//] _ [<-].
    move=> a ma ih [//|b mb] /=.
    t_xrbindP=> _ r hf lr /ih{ih}ih <- /=.
    by Psatz.lia.
  Qed.

  Lemma mapM2_Forall2 (P: R → B → Prop) ma mb mr :
    (∀ a b r, List.In (a, b) (zip ma mb) → f a b = ok r → P r b) →
    mapM2 ma mb = ok mr →
    List.Forall2 P mr mb.
  Proof.
    elim: ma mb mr.
    + move => [] // mr _ [<-]; constructor.
    move => a ma ih [] // b mb mr' h /=; t_xrbindP => r ok_r mr rec <- {mr'}.
    constructor.
    + by apply: (h _ _ _ _ ok_r); left.
    by apply: ih => // a' b' r' h' ok_r'; apply: (h a' b' r' _ ok_r'); right.
  Qed.

  Lemma mapM2_Forall3 ma mb mr :
    mapM2 ma mb = ok mr ->
    Forall3 (fun a b r => f a b = ok r) ma mb mr.
  Proof.
    elim: ma mb mr.
    + by move=> [|//] [|//] _; constructor.
    move=> a ma ih [//|b mb] /=.
    t_xrbindP=> _ r h mr /ih{ih}ih <-.
    by constructor.
  Qed.

End MAP2.

Section FMAP.

  Context (A B C:Type) (f : A -> B -> A * C).

  Fixpoint fmap (a:A) (bs:seq B) : A * seq C :=
    match bs with
    | [::] => (a, [::])
    | b::bs =>
      let (a, c) := f a b in
      let (a, cs) := fmap a bs in
      (a, c :: cs)
    end.

End FMAP.

Definition fmapM {eT aT bT cT} (f : aT -> bT -> result eT (aT * cT))  : aT -> seq bT -> result eT (aT * seq cT) :=
  fix mapM a xs :=
    match xs with
    | [::] => Ok eT (a, [::])
    | [:: x & xs] =>
      Let y := f a x in
      Let ys := mapM y.1 xs in
      Ok eT (ys.1, y.2 :: ys.2)
    end.

Definition fmapM2 {eT aT bT cT dT} (e:eT) (f : aT -> bT -> cT -> result eT (aT * dT)) :
   aT -> seq bT -> seq cT -> result eT (aT * seq dT) :=
  fix mapM a lb lc :=
    match lb, lc with
    | [::], [::] => Ok eT (a, [::])
    | [:: b & bs], [:: c & cs] =>
      Let y := f a b c in
      Let ys := mapM y.1 bs cs in
      Ok eT (ys.1, y.2 :: ys.2)
    | _, _ => Error e
    end.

Lemma size_fmapM2 {eT aT bT cT dT} e (f : aT -> bT -> cT -> result eT (aT * dT)) a lb lc a2 ld :
  fmapM2 e f a lb lc = ok (a2, ld) ->
  size lb = size lc /\ size lb = size ld.
Proof.
  elim: lb lc a a2 ld.
  + by move=> [|//] _ _ _ [_ <-].
  move=> b lb ih [//|c lc] a /=.
  t_xrbindP=> _ _ _ _ [_ ld] /ih{ih}ih _ <- /=.
  by Psatz.lia.
Qed.

(* Forall and size *)
(* -------------------------------------------------------------- *)

Lemma Forall2_size A B (R : A -> B -> Prop) la lb :
  List.Forall2 R la lb -> size la = size lb.
Proof. by elim {la lb} => // a b la lb _ _ /= ->. Qed.

Lemma Forall3_size A B C (R : A -> B -> C -> Prop) l1 l2 l3 :
  Forall3 R l1 l2 l3 ->
  size l1 = size l2 /\ size l1 = size l3.
Proof. by elim {l1 l2 l3} => // a b c l1 l2 l3 _ _ /= [<- <-]. Qed.

(* Reasoning with Forall *)
(* -------------------------------------------------------------- *)

Lemma Forall_nth A (R : A -> Prop) l :
  List.Forall R l ->
  forall d i, (i < size l)%nat -> R (nth d l i).
Proof.
  elim {l} => // a l h _ ih d [//|i].
  by apply ih.
Qed.

Lemma nth_Forall A (R : A -> Prop) l d :
  (forall i, (i < size l)%nat -> R (nth d l i)) ->
  List.Forall R l.
Proof.
  elim: l => //.
  move=> a l ih h.
  constructor.
  + by apply (h 0%nat).
  apply ih.
  by move=> i; apply (h i.+1).
Qed.
Arguments nth_Forall [A R l].

Lemma Forall2_nth A B (R : A -> B -> Prop) la lb :
  List.Forall2 R la lb ->
  forall a b i, (i < size la)%nat ->
  R (nth a la i) (nth b lb i).
Proof.
  elim {la lb} => // a b la lb h _ ih a0 b0 [//|i].
  by apply ih.
Qed.

Lemma nth_Forall2 A B (R : A -> B -> Prop) la lb a b:
  size la = size lb ->
  (forall i, (i < size la)%nat -> R (nth a la i) (nth b lb i)) ->
  List.Forall2 R la lb.
Proof.
  elim: la lb.
  + by move=> [|//] _ _; constructor.
  move=> a0 la ih [//|b0 lb] [hsize] h.
  constructor.
  + by apply (h 0%nat).
  apply ih => //.
  by move=> i; apply (h i.+1).
Qed.
Arguments nth_Forall2 [A B R la lb].

Lemma Forall2_forall A B (R : A -> B -> Prop) la lb :
  List.Forall2 R la lb ->
  forall a b, List.In (a, b) (zip la lb) ->
  R a b.
Proof.
  elim {la lb} => // a b la lb h _ ih a0 b0 /=.
  case.
  + by move=> [<- <-].
  by apply ih.
Qed.

Lemma forall_Forall2 A B (R : A -> B -> Prop) la lb :
  size la = size lb ->
  (forall a b, List.In (a, b) (zip la lb) -> R a b) ->
  List.Forall2 R la lb.
Proof.
  elim: la lb.
  + by move=> [|//]; constructor.
  move=> a la ih [//|b l2] [hsize] h.
  constructor.
  + by apply h; left.
  apply ih => //.
  by move=> ???; apply h; right.
Qed.

Lemma Forall2_impl A B (R1 R2 : A -> B -> Prop) :
  (forall a b, R1 a b -> R2 a b) ->
  forall la lb,
  List.Forall2 R1 la lb ->
  List.Forall2 R2 la lb.
Proof. by move=> himpl l1 l2; elim; eauto. Qed.

Lemma Forall2_impl_in A B (R1 R2 : A -> B -> Prop) la lb :
  (forall a b, List.In a la -> List.In b lb -> R1 a b -> R2 a b) ->
  List.Forall2 R1 la lb ->
  List.Forall2 R2 la lb.
Proof.
  move=> himpl hforall.
  elim: {la lb} hforall himpl.
  + by constructor.
  move=> a b la lb h _ ih himpl.
  constructor.
  + by apply himpl; [left; reflexivity..|].
  apply ih.
  by move=> ?????; apply himpl; [right..|].
Qed.

Lemma Forall3_nth A B C (R : A -> B -> C -> Prop) la lb lc :
  Forall3 R la lb lc ->
  forall a b c i,
  (i < size la)%nat ->
  R (nth a la i) (nth b lb i) (nth c lc i).
Proof.
  elim {la lb lc} => // a b c la lb lc hr _ ih a0 b0 c0 [//|i].
  by apply ih.
Qed.

Lemma nth_Forall3 A B C (R : A -> B -> C -> Prop) la lb lc a b c:
  size la = size lb -> size la = size lc ->
  (forall i, (i < size la)%nat -> R (nth a la i) (nth b lb i) (nth c lc i)) ->
  Forall3 R la lb lc.
Proof.
  elim: la lb lc.
  + by move=> [|//] [|//] _ _ _; constructor.
  move=> a0 l1 ih [//|b0 l2] [//|c0 l3] [hsize1] [hsize2] h.
  constructor.
  + by apply (h 0%nat).
  apply ih => //.
  by move=> i; apply (h i.+1).
Qed.
Arguments nth_Forall3 [A B C R la lb lc].

Lemma Forall3_forall A B C (R : A -> B -> C -> Prop) la lb lc :
  Forall3 R la lb lc ->
  forall a b c, List.In (a, (b, c)) (zip la (zip lb lc)) -> R a b c.
Proof.
  elim {la lb lc} => // a b c la lb lc h _ ih a0 b0 c0 /=.
  case.
  + by move=> [<- <- <-].
  by apply ih.
Qed.

Lemma forall_Forall3 A B C (R : A -> B -> C -> Prop) la lb lc :
  size la = size lb -> size la = size lc ->
  (forall a b c, List.In (a, (b, c)) (zip la (zip lb lc)) -> R a b c) ->
  Forall3 R la lb lc.
Proof.
  elim: la lb lc.
  + by move=> [|//] [|//]; constructor.
  move=> a la ih [//|b l2] [//|c l3] [hsize1] [hsize2] h.
  constructor.
  + by apply h; left.
  apply ih => //.
  by move=> ????; apply h; right.
Qed.

Lemma Forall3_impl A B C (R1 R2 : A -> B -> C -> Prop) :
  (forall a b c, R1 a b c -> R2 a b c) ->
  forall la lb lc,
  Forall3 R1 la lb lc ->
  Forall3 R2 la lb lc.
Proof. by move=> himpl l1 l2 l3; elim; eauto using Forall3. Qed.

Lemma Forall3_impl_in A B C (R1 R2 : A -> B -> C -> Prop) la lb lc :
  (forall a b c, List.In a la -> List.In b lb -> List.In c lc -> R1 a b c -> R2 a b c) ->
  Forall3 R1 la lb lc ->
  Forall3 R2 la lb lc.
Proof.
  move=> himpl hforall.
  elim: {la lb lc} hforall himpl.
  + by constructor.
  move=> a b c la lb lc h _ ih himpl.
  constructor.
  + by apply himpl; [left; reflexivity..|].
  apply ih.
  by move=> ???????; apply himpl; [right..|].
Qed.

(* Inversion lemmas *)
(* -------------------------------------------------------------- *)
Lemma seq_eq_injL A (m n: seq A) (h: m = n) :
  match m with
  | [::] => if n is [::] then True else False
  | a :: m' => if n is b :: n' then a = b ∧ m' = n' else False
  end.
Proof. by subst n; case: m. Qed.

Lemma List_Forall_inv A (P: A → Prop) m :
  List.Forall P m →
  match m with [::] => True | x :: m' => P x ∧ List.Forall P m' end.
Proof. by case. Qed.

Lemma List_Forall2_refl A (R:A->A->Prop) l : (forall a, R a a) -> List.Forall2 R l l.
Proof. by move=> HR;elim: l => // a l Hrec;constructor. Qed.

Lemma List_Forall2_inv_l A B (R: A → B → Prop) m n :
  List.Forall2 R m n →
  match m with
  | [::] => n = [::]
  | a :: m' => ∃ b n', n = b :: n' ∧ R a b ∧ List.Forall2 R m' n'
  end.
Proof. case; eauto. Qed.

Lemma List_Forall2_inv_r A B (R: A → B → Prop) m n :
  List.Forall2 R m n →
  match n with
  | [::] => m = [::]
  | b :: n' => ∃ a m', m = a :: m' ∧ R a b ∧ List.Forall2 R m' n'
  end.
Proof. case; eauto. Qed.

Lemma List_Forall2_inv A B (R: A → B → Prop) m n :
  List.Forall2 R m n →
  if m is a :: m' then if n is b :: n' then R a b ∧ List.Forall2 R m' n' else False else if n is [::] then True else False.
Proof. case; auto. Qed.

Lemma List_Forall3_inv A B C (R : A -> B -> C -> Prop) l1 l2 l3 :
  Forall3 R l1 l2 l3 ->
  match l1, l2, l3 with
  | [::], [::], [::] => True
  | a :: l1, b :: l2, c :: l3 => R a b c /\ Forall3 R l1 l2 l3
  | _, _, _ => False
  end.
Proof. by case. Qed.

Section Subseq.

  Context (T : eqType).
  Context (p : T -> bool).

  Lemma subseq_has s1 s2 : subseq s1 s2 -> has p s1 -> has p s2.
  Proof.
    move=> /mem_subseq hsub /hasP [x /hsub hin hp].
    apply /hasP.
    by exists x.
  Qed.

  Lemma subseq_all s1 s2 : subseq s1 s2 -> all p s2 -> all p s1.
  Proof.
    move=> /mem_subseq hsub /allP hall.
    by apply /allP => x /hsub /hall.
  Qed.

End Subseq.

Section All2.

Section DifferentTypes.

  Context (S T : Type).
  Context (p : S -> T -> bool).

  Lemma all2P l1 l2 : reflect (List.Forall2 p l1 l2) (all2 p l1 l2).
  Proof.
    elim: l1 l2 => [ | a l1 hrec] [ | b l2] /=;try constructor.
    + by constructor.
    + by move/List_Forall2_inv_l.
    + by move/List_Forall2_inv_r.
    apply: equivP;first apply /andP.
    split => [[]h1 /hrec h2 |];first by constructor.
    by case/List_Forall2_inv_l => b' [n] [] [-> ->] [->] /hrec.
  Qed.

  Section Ind.

    Context (P : list S -> list T -> Prop).

    Lemma list_all2_ind :
      P [::] [::] ->
      (forall x1 l1 x2 l2, p x1 x2 -> all2 p l1 l2 -> P l1 l2 -> P (x1::l1) (x2::l2)) ->
      forall l1 l2, all2 p l1 l2 -> P l1 l2.
    Proof.
      move=> hnil hcons; elim => /=; first by case.
      move=> x1 l1 ih [//|x2 l2] /andP [hf hall2].
      by apply hcons => //; apply ih.
    Qed.

  End Ind.

End DifferentTypes.

Section SameType.

  Context (T : Type).

  Section AnyRelation.

    Context (p : rel T).

    Lemma all2_refl : ssrbool.reflexive p -> ssrbool.reflexive (all2 p).
    Proof.
      move=> hrefl.
      by elim=> //= a l ih; apply /andP.
    Qed.

    Lemma all2_trans : ssrbool.transitive p -> ssrbool.transitive (all2 p).
    Proof.
      move=> htrans s1 s2 s3 hall2; move: hall2 s3.
      elim/list_all2_ind {s1 s2} => //= x1 s1 x2 s2 hp12 _ ih [//|x3 s3] /andP [hp23 hall2].
      by apply /andP; eauto.
    Qed.

  End AnyRelation.

  Section Eqb.

    Variable eqb: T -> T -> bool.
    Variable Heq : forall (x y:T), reflect (x = y) (eqb x y).

    Lemma reflect_all2_eqb l1 l2 : reflect (l1 = l2) (all2 eqb l1 l2).
    Proof.
      elim: l1 l2 => [|e1 l1 Hrec1] [|e2 l2] /=; try by constructor.
      by apply (iffP andP) => -[] /Heq -> /Hrec1 ->.
    Defined.

  End Eqb.

End SameType.

End All2.

Section Map2.

  Context (A B C : Type) (f : A -> B -> C).

  Fixpoint map2 la lb :=
    match la, lb with
    | a::la, b::lb => f a b :: map2 la lb
    | _, _         => [::]
    end.

  Lemma map2E ma mb :
    map2 ma mb = map (λ ab, f ab.1 ab.2) (zip ma mb).
  Proof.
    elim: ma mb; first by case.
    by move => a ma ih [] // b mb /=; f_equal.
  Qed.

End Map2.

Section Map3.

  Context (A B C D : Type) (f : A -> B -> C -> D).

  Fixpoint map3 ma mb mc :=
    match ma, mb, mc with
    | a :: ma', b :: mb', c :: mc' => f a b c :: map3 ma' mb' mc'
    | _, _, _ => [::]
    end.

  Lemma map3E ma mb mc :
    map3 ma mb mc = map2 (λ ab, f ab.1 ab.2) (zip ma mb) mc.
  Proof.
    elim: ma mb mc; first by case.
    by move => a ma ih [] // b mb [] // c mc /=; f_equal.
  Qed.

End Map3.

Section MAPI.

  Context (A : Type) (a : A) (B:Type) (b : B) (f : nat -> A -> B).

  Fixpoint mapi_aux k l :=
    match l with
    | [::] => [::]
    | a::l=> f k a :: mapi_aux k.+1 l
    end.

  Definition mapi := mapi_aux 0.

  Lemma size_mapi_aux k l : size (mapi_aux k l) = size l.
  Proof.
    elim: l k => //= a' l ih k.
    by rewrite ih.
  Qed.

  Lemma size_mapi l : size (mapi l) = size l.
  Proof. exact: size_mapi_aux. Qed.

  Lemma nth_mapi_aux n k l :
    (n < size l)%nat -> nth b (mapi_aux k l) n = f (k+n) (nth a l n).
  Proof.
    elim: l n k => //= a' l ih n k hlt.
    case: n hlt => /=.
    + by move=> _; rewrite addn0.
    by move=> n hlt; rewrite ih // addSnnS.
  Qed.

  Lemma nth_mapi n l :
    (n < size l)%nat -> nth b (mapi l) n = f n (nth a l n).
  Proof. exact: nth_mapi_aux. Qed.

End MAPI.

Section FIND_MAP.

Context {A : eqType} {B : Type}.

Section DEF.

Context (f: A -> option B).

(* The name comes from OCaml. *)
Fixpoint find_map l :=
  match l with
  | [::] => None
  | a::l =>
    match f a with
    | Some b => Some b
    | None => find_map l
    end
  end.

End DEF.

Lemma find_map_correct {f l b} :
  find_map f l = Some b -> exists2 a, a \in l & f a = Some b.
Proof.
  elim: l => //= a l ih.
  case heq: (f a) => [b'|].
  + by move=> [<-]; exists a => //; rewrite mem_head.
  move=> /ih [a' h1 h2]; exists a'=> //.
  by rewrite in_cons; apply /orP; right.
Qed.

End FIND_MAP.

(* ** Misc functions
 * -------------------------------------------------------------------- *)

Definition isSome aT (o : option aT) :=
  if o is Some _ then true else false.

Lemma isSome_obind (aT bT: Type) (f: aT → option bT) (o: option aT) :
  reflect (exists2 a, o = Some a & isSome (f a)) (isSome (o >>= f)%O).
Proof.
  apply: Bool.iff_reflect; split.
  - by case => a ->.
  by case: o => // a h; exists a.
Qed.

Fixpoint list_to_rev (ub : nat) :=
  match ub with
  | O    => [::]
  | x.+1 => [:: x & list_to_rev x ]
  end.

Definition list_to ub := rev (list_to_rev ub).

Lemma Forall2_trans (A B C:Type) l2 (R1:A->B->Prop) (R2:B->C->Prop)
                    l1 l3 (R3:A->C->Prop)  :
   (forall b a c, R1 a b -> R2 b c -> R3 a c) ->
   List.Forall2 R1 l1 l2 ->
   List.Forall2 R2 l2 l3 ->
   List.Forall2 R3 l1 l3.
Proof.
  move=> H hr1;elim: hr1 l3 => {l1 l2} [ | a b l1 l2 hr1 _ hrec] l3 /List_Forall2_inv_l.
  + by move => ->.
   by case => ? [?] [->] [??]; constructor; eauto.
Qed.

Definition conc_map aT bT (f : aT -> seq bT) (l : seq aT) :=
  flatten (map f l).

(* -------------------------------------------------------------------------- *)
(* Operators to build comparison                                              *)
(* ---------------------------------------------------------------------------*)

Section CTRANS.

  Definition ctrans c1 c2 := nosimpl (
    match c1, c2 with
    | Eq, _  => Some c2
    | _ , Eq => Some c1
    | Lt, Lt => Some Lt
    | Gt, Gt => Some Gt
    | _ , _  => None
    end).

  Lemma ctransI c : ctrans c c = Some c.
  Proof. by case: c. Qed.

  Lemma ctransC c1 c2 : ctrans c1 c2 = ctrans c2 c1.
  Proof. by case: c1 c2 => -[]. Qed.

  Lemma ctrans_Eq c1 c2 : ctrans Eq c1 = Some c2 <-> c1 = c2.
  Proof. by rewrite /ctrans;case:c1=> //=;split=>[[]|->]. Qed.

  Lemma ctrans_Lt c1 c2 : ctrans Lt c1 = Some c2 -> Lt = c2.
  Proof. by rewrite /ctrans;case:c1=> //= -[] <-. Qed.

  Lemma ctrans_Gt c1 c2 : ctrans Gt c1 = Some c2 -> Gt = c2.
  Proof. by rewrite /ctrans;case:c1=> //= -[] <-. Qed.

End CTRANS.

Notation Lex u v :=
  match u with
  | Lt => Lt
  | Eq => v
  | Gt => Gt
  end.

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

Scheme Equality for comparison.

Lemma comparison_beqP : Equality.axiom comparison_beq.
Proof.
  move=> e1 e2;case Heq: comparison_beq;constructor.
  + by apply: internal_comparison_dec_bl.
  by move=> /internal_comparison_dec_lb;rewrite Heq.
Qed.

Canonical comparison_eqMixin := EqMixin comparison_beqP.
Canonical comparison_eqType := Eval hnf in EqType comparison comparison_eqMixin.

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

Class Cmp {T:Type} (cmp:T -> T -> comparison) := {
    cmp_sym    : forall x y, cmp x y = CompOpp (cmp y x);
    cmp_ctrans : forall y x z c, ctrans (cmp x y) (cmp y z) = Some c -> cmp x z = c;
    cmp_eq     : forall {x y}, cmp x y = Eq -> x = y;
  }.

Definition gcmp {T:Type} {cmp:T -> T -> comparison} {C:Cmp cmp} := cmp.

Section CMP.

  Context {T:Type} {cmp:T -> T -> comparison} {C:Cmp cmp}.

  Lemma cmp_trans y x z c:
    cmp x y = c -> cmp y z = c -> cmp x z = c.
  Proof.
    by move=> H1 H2;apply (@cmp_ctrans _ _ C y);rewrite H1 H2 ctransI.
  Qed.

  Lemma cmp_refl x : cmp x x = Eq.
  Proof. by have := @cmp_sym _ _ C x x;case: (cmp x x). Qed.

  Definition cmp_lt x1 x2 := gcmp x1 x2 == Lt.

  Definition cmp_le x1 x2 := gcmp x2 x1 != Lt.

  Lemma cmp_le_refl x : cmp_le x x.
  Proof. by rewrite /cmp_le /gcmp cmp_refl. Qed.

  Lemma cmp_lt_trans y x z : cmp_lt x y -> cmp_lt y z -> cmp_lt x z.
  Proof.
    rewrite /cmp_lt /gcmp => /eqP h1 /eqP h2;apply /eqP;apply (@cmp_ctrans _ _ C y).
    by rewrite h1 h2.
  Qed.

  Lemma cmp_le_trans y x z : cmp_le x y -> cmp_le y z -> cmp_le x z.
  Proof.
    rewrite /cmp_le /gcmp => h1 h2;have := (@cmp_ctrans _ _ C y z x).
    by case: cmp h1 => // _;case: cmp h2 => //= _;rewrite /ctrans => /(_ _ erefl) ->.
  Qed.

  Lemma cmp_nle_lt x y: ~~ (cmp_le x y) = cmp_lt y x.
  Proof. by rewrite /cmp_le /cmp_lt /gcmp Bool.negb_involutive. Qed.

  Lemma cmp_nlt_le x y: ~~ (cmp_lt x y) = cmp_le y x.
  Proof. done. Qed.

  Lemma cmp_lt_le_trans y x z: cmp_lt x y -> cmp_le y z -> cmp_lt x z.
  Proof.
    rewrite /cmp_le /cmp_lt /gcmp (cmp_sym z) => h1 h2.
    have := (@cmp_ctrans _ _ C y x z).
    by case: cmp h1 => // _;case: cmp h2 => //= _;rewrite /ctrans => /(_ _ erefl) ->.
  Qed.

  Lemma cmp_le_lt_trans y x z: cmp_le x y -> cmp_lt y z -> cmp_lt x z.
  Proof.
    rewrite /cmp_le /cmp_lt /gcmp (cmp_sym y) => h1 h2.
    have := (@cmp_ctrans _ _ C y x z).
    by case: cmp h1 => // _;case: cmp h2 => //= _;rewrite /ctrans => /(_ _ erefl) ->.
  Qed.

  Lemma cmp_lt_le x y : cmp_lt x y -> cmp_le x y.
  Proof.
    rewrite /cmp_lt /cmp_le /gcmp => /eqP h.
    by rewrite cmp_sym h.
  Qed.

  Lemma cmp_nle_le x y : ~~ (cmp_le x y) -> cmp_le y x.
  Proof. by rewrite cmp_nle_lt; apply: cmp_lt_le. Qed.

  Definition min (t1 t2: T) :=
    if cmp_le t1 t2 then t1 else t2.

  Definition max (t1 t2: T) :=
    if cmp_le t1 t2 then t2 else t1.

End CMP.

Declare Scope cmp_scope.
Notation "m < n" := (cmp_lt m n) : cmp_scope.
Notation "m <= n" := (cmp_le m n) : cmp_scope.
Notation "m ≤ n" := (cmp_le m n) : cmp_scope.
Delimit Scope cmp_scope with CMP.

#[global]
Hint Resolve cmp_le_refl : core.

Section EqCMP.

  Context {T:eqType} {cmp:T -> T -> comparison} {C:Cmp cmp}.

  Lemma cmp_le_eq_lt (s1 s2:T): cmp_le s1 s2 = cmp_lt s1 s2 || (s1 == s2).
  Proof.
    rewrite /cmp_le /cmp_lt cmp_sym /gcmp.
    case heq: cmp => //=.
    + by rewrite (cmp_eq heq) eqxx.
    case: eqP => // ?;subst.
    by rewrite cmp_refl in heq.
  Qed.

  Lemma cmp_le_antisym x y :
    cmp_le x y → cmp_le y x → x = y.
  Proof.
    by rewrite -cmp_nlt_le (cmp_le_eq_lt y) => /negbTE -> /eqP.
  Qed.

End EqCMP.

Section LEX.

  Variables (T1 T2:Type) (cmp1:T1 -> T1 -> comparison) (cmp2:T2 -> T2 -> comparison).

  Definition lex x y := Lex (cmp1 x.1 y.1) (cmp2 x.2 y.2).

  Lemma Lex_lex x1 x2 y1 y2 : Lex (cmp1 x1 y1) (cmp2 x2 y2) = lex (x1,x2) (y1,y2).
  Proof. done. Qed.

  Lemma lex_sym x y :
    cmp1 x.1 y.1 = CompOpp (cmp1 y.1 x.1) ->
    cmp2 x.2 y.2 = CompOpp (cmp2 y.2 x.2) ->
    lex  x y = CompOpp (lex  y x).
  Proof.
    by move=> H1 H2;rewrite /lex H1;case: cmp1=> //=;apply H2.
  Qed.

  Lemma lex_trans y x z:
    (forall c, ctrans (cmp1 x.1 y.1) (cmp1 y.1 z.1) = Some c -> cmp1 x.1 z.1 = c) ->
    (forall c, ctrans (cmp2 x.2 y.2) (cmp2 y.2 z.2) = Some c -> cmp2 x.2 z.2 = c) ->
    forall  c, ctrans (lex x y) (lex y z) = Some c -> lex x z = c.
  Proof.
    rewrite /lex=> Hr1 Hr2 c;case: cmp1 Hr1.
    + move=> H;rewrite (H (cmp1 y.1 z.1));last by rewrite ctrans_Eq.
      (case: cmp1;first by apply Hr2);
        rewrite ctransC; [apply ctrans_Lt | apply ctrans_Gt].
    + move=> H1 H2;rewrite (H1 Lt);move:H2;first by apply: ctrans_Lt.
      by case: cmp1.
    move=> H1 H2;rewrite (H1 Gt);move:H2;first by apply: ctrans_Gt.
    by case: cmp1.
  Qed.

  Lemma lex_eq x y :
    lex x y = Eq -> cmp1 x.1 y.1 = Eq /\ cmp2 x.2 y.2 = Eq.
  Proof.
    case: x y => [x1 x2] [y1 y2] /=.
    by rewrite /lex;case:cmp1 => //;case:cmp2.
  Qed.

  Lemma LexO (C1:Cmp cmp1) (C2:Cmp cmp2) : Cmp lex.
  Proof.
    constructor=> [x y | y x z | x y].
    + by apply /lex_sym;apply /cmp_sym.
    + by apply /lex_trans;apply /cmp_ctrans.
    by case: x y => ?? [??] /lex_eq /= [] /(@cmp_eq _ _ C1) -> /(@cmp_eq _ _ C2) ->.
  Qed.

End LEX.

Section MIN.
  Context T (cmp: T → T → comparison) (O: Cmp cmp).
  Definition cmp_min (x y: T) : T :=
    if (x ≤ y)%CMP then x else y.

  Lemma cmp_minP x y (P: T → Prop) :
    ((x ≤ y)%CMP → P x) →
    ((y < x)%CMP → P y) →
    P (cmp_min x y).
  Proof.
    rewrite /cmp_min; case: ifP.
    - by move => _ /(_ erefl).
    by rewrite -cmp_nle_lt => -> _ /(_ erefl).
  Qed.

  Lemma cmp_min_leL x y :
    (cmp_min x y ≤ x)%CMP.
  Proof.
    apply: (@cmp_minP x y (λ z, z ≤ x)%CMP) => //.
    apply: cmp_lt_le.
  Qed.

  Lemma cmp_min_leR x y :
    (cmp_min x y ≤ y)%CMP.
  Proof. exact: (@cmp_minP x y (λ z, z ≤ y)%CMP). Qed.

  Lemma cmp_le_min x y :
    (x ≤ y)%CMP → cmp_min x y = x.
  Proof. by rewrite /cmp_min => ->. Qed.

End MIN.

Arguments cmp_min {T cmp O} x y.

Definition bool_cmp b1 b2 :=
  match b1, b2 with
  | false, true  => Lt
  | false, false => Eq
  | true , true  => Eq
  | true , false => Gt
  end.

#[global]
Instance boolO : Cmp bool_cmp.
Proof.
  constructor=> [[] [] | [] [] [] c | [] []] //=; apply ctrans_Eq.
Qed.

#[global]
Polymorphic Instance subrelation_iff_flip_arrow : subrelation iffT (flip arrow).
Proof. by move=> ?? []. Qed.

#[global]
Instance reflect_m: Proper (iff ==> (@eq bool) ==> iffT) reflect.
Proof. by move=> P1 P2 Hiff b1 b2 ->; split=> H; apply (equivP H);rewrite Hiff. Qed.

Coercion Zpos : positive >-> Z.

Lemma P_leP (x y:positive) : reflect (x <= y)%Z (x <=? y)%positive.
Proof. apply: (@equivP (Pos.le x y)) => //;rewrite -Pos.leb_le;apply idP. Qed.

Lemma P_ltP (x y:positive) : reflect (x < y)%Z (x <? y)%positive.
Proof. apply: (@equivP (Pos.lt x y)) => //;rewrite -Pos.ltb_lt;apply idP. Qed.

Lemma Pos_leb_trans y x z:
  (x <=? y)%positive -> (y <=? z)%positive -> (x <=? z)%positive.
Proof. move=> /P_leP ? /P_leP ?;apply /P_leP; Lia.lia. Qed.

Lemma Pos_lt_leb_trans y x z:
  (x <? y)%positive -> (y <=? z)%positive -> (x <? z)%positive.
Proof. move=> /P_ltP ? /P_leP ?;apply /P_ltP; Lia.lia. Qed.

Lemma pos_eqP : Equality.axiom Pos.eqb.
Proof. by move=> p1 p2;apply:(iffP idP);rewrite -Pos.eqb_eq. Qed.

Definition pos_eqMixin := EqMixin pos_eqP.
Canonical  pos_eqType  := EqType positive pos_eqMixin.

#[global]
Instance positiveO : Cmp Pos.compare.
Proof.
  constructor.
  + by move=> ??;rewrite Pos.compare_antisym.
  + move=> ????;case:Pos.compare_spec=> [->|H1|H1];
    case:Pos.compare_spec=> H2 //= -[] <- //;subst;
    rewrite ?Pos.compare_lt_iff ?Pos.compare_gt_iff //.
    + by apply: Pos.lt_trans H1 H2.
    by apply: Pos.lt_trans H2 H1.
  apply Pos.compare_eq.
Qed.

#[global]
Instance ZO : Cmp Z.compare.
Proof.
  constructor.
  + by move=> ??;rewrite Z.compare_antisym.
  + move=> ????;case:Z.compare_spec=> [->|H1|H1];
    case:Z.compare_spec=> H2 //= -[] <- //;subst;
    rewrite ?Z.compare_lt_iff ?Z.compare_gt_iff //.
    + by apply: Z.lt_trans H1 H2.
    by apply: Z.lt_trans H2 H1.
  apply Z.compare_eq.
Qed.

Lemma Z_to_nat_le0 z : z <= 0 -> Z.to_nat z = 0%N.
Proof. by rewrite /Z.to_nat; case: z => //=; rewrite /Z.le. Qed.

Lemma Z_odd_pow_2 n x :
  (0 < n)%Z
  -> Z.odd (2 ^ n * x) = false.
Proof.
  move=> hn.
  rewrite Z.odd_mul.
  by rewrite (Z.odd_pow _ _ hn).
Qed.

(* ** Some Extra tactics
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
Variant dup_spec (P : Prop) :=
| Dup of P & P.

Lemma dup (P : Prop) : P -> dup_spec P.
Proof. by move=> ?; split. Qed.

(* -------------------------------------------------------------------- *)
Definition ZleP : ∀ x y, reflect (x <= y) (x <=? y) := Z.leb_spec0.
Definition ZltP : ∀ x y, reflect (x < y) (x <? y) := Z.ltb_spec0.

(* -------------------------------------------------------------------- *)
Section NAT.

Open Scope nat.

Lemma ZNleP x y :
  reflect (Z.of_nat x <= Z.of_nat y)%Z (x <= y).
Proof.
  case h: (x <= y).
  all: move: h => /leP /Nat2Z.inj_le.
  all: by constructor.
Qed.

Lemma ZNltP x y :
  reflect (Z.of_nat x < Z.of_nat y)%Z (x < y).
Proof.
  case h: (x < y).
  all: move: h => /ZNleP.
  all: rewrite Nat2Z.inj_succ.
  all: move=> /Z.le_succ_l.
  all: by constructor.
Qed.

Lemma lt_nm_n n m :
  n + m < n = false.
Proof.
  rewrite -{2}(addn0 n).
  rewrite ltn_add2l.
  exact: ltn0.
Qed.

Lemma sub_nmn n m :
  n + m - n = m.
Proof.
  elim: n => //.
  by rewrite add0n subn0.
Qed.

End NAT.

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

Lemma rwR1 (A:Type) (P:A->Prop) (f:A -> bool) :
  (forall a, reflect (P a) (f a)) ->
  forall a, (f a) <-> (P a).
Proof. by move=> h a; rewrite (rwP (h _)). Qed.

Lemma rwR2 (A B:Type) (P:A->B->Prop) (f:A -> B -> bool) :
  (forall a b, reflect (P a b) (f a b)) ->
  forall a b, (f a b) <-> (P a b).
Proof. by move=> h a b; rewrite (rwP (h _ _)). Qed.

Notation pify :=
  (rwR2 (@andP), rwR2 (@orP), rwR2 (@implyP), rwR1 (@forallP _), rwR1 (@negP)).

Lemma Zcmp_le i1 i2 : (i1 <= i2)%CMP = (i1 <=? i2)%Z.
Proof.
  rewrite /cmp_le /gcmp /Z.leb -Zcompare_antisym.
  by case: Z.compare.
Qed.

Lemma Zcmp_lt i1 i2 : (i1 < i2)%CMP = (i1 <? i2)%Z.
Proof.
  rewrite /cmp_lt /gcmp /Z.ltb.
  by case: Z.compare.
Qed.

Notation zify := (Zcmp_le, Zcmp_lt, pify, (rwR2 (@ZleP), rwR2 (@ZltP))).

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

Definition ziota p (z:Z) := [seq p + Z.of_nat i | i <- iota 0 (Z.to_nat z)].

Lemma ziota0 p : ziota p 0 = [::].
Proof. done. Qed.

Lemma ziota_neg p z: z <= 0 -> ziota p z = [::].
Proof. by case: z. Qed.

Lemma ziotaS_cons p z: 0 <= z -> ziota p (Z.succ z) = p :: ziota (p+1) z.
Proof.
  move=> hz;rewrite /ziota Z2Nat.inj_succ //= Z.add_0_r; f_equal.
  rewrite -addn1 addnC iotaDl -map_comp.
  by apply eq_map => i /=; rewrite Zpos_P_of_succ_nat;Psatz.lia.
Qed.

Lemma ziotaS_cat p z: 0 <= z -> ziota p (Z.succ z) = ziota p z ++ [:: p + z].
Proof.
  by move=> hz;rewrite /ziota Z2Nat.inj_succ // -addn1 iotaD map_cat /= add0n Z2Nat.id.
Qed.

Lemma in_ziota (p z i:Z) : (i \in ziota p z) = ((p <=? i) && (i <? p + z)).
Proof.
  case: (ZleP 0 z) => hz.
  + move: p; pattern z; apply natlike_ind => [ p | {z hz} z hz hrec p| //].
    + by rewrite ziota0 in_nil; case: andP => // -[/ZleP ? /ZltP ?]; Psatz.lia.
    rewrite ziotaS_cons // in_cons; case: eqP => [-> | ?] /=.
    + by rewrite Z.leb_refl /=; symmetry; apply /ZltP; Psatz.lia.
    by rewrite hrec; apply Bool.eq_iff_eq_true;split=> /andP [/ZleP ? /ZltP ?];
      (apply /andP;split;[apply /ZleP| apply /ZltP]); Psatz.lia.
  rewrite ziota_neg;last Psatz.lia.
  rewrite in_nil;symmetry;apply /negP => /andP [/ZleP ? /ZltP ?]; Psatz.lia.
Qed.

Lemma size_ziota p z: size (ziota p z) = Z.to_nat z.
Proof. by rewrite size_map size_iota. Qed.

Lemma nth_ziota p (i:nat) z : leq (S i) (Z.to_nat z) ->
   nth 0%Z (ziota p z) i = (p + Z.of_nat i)%Z.
Proof.
  by move=> hi;rewrite (nth_map O) ?size_iota // nth_iota.
Qed.

Lemma list_all_ind (Q : Z -> bool) (P : list Z -> Prop):
  P [::] ->
  (forall i l, Q i -> all Q l -> P l -> P (i::l))->
  (forall l, all Q l -> P l).
Proof.
  move=> hnil hcons; elim => //= a l hrec /andP [hQ hall].
  by apply hcons => //; apply hrec.
Qed.

Lemma ziota_ind (P : list Z -> Prop) p1 p2:
  P [::] ->
  (forall i l, p1 <= i < p1 + p2 -> P l -> P (i::l))->
  P (ziota p1 p2).
Proof.
  move=> hnil hcons.
  have: all (fun i =>  (p1 <=? i) && (i <? p1 + p2)) (ziota p1 p2).
  + by apply/allP => i; rewrite in_ziota !zify.
  by elim/list_all_ind => // i l; rewrite !zify => *;apply hcons.
Qed.

Lemma all_ziota p1 p2 (f1 f2: Z -> bool) :
  (forall i, (p1 <= i < p1 + p2)%Z -> f1 i = f2 i) ->
  all f1 (ziota p1 p2) = all f2 (ziota p1 p2).
Proof. by move => h; apply ziota_ind => //= i l /h -> ->. Qed.

(* ------------------------------------------------------------------------- *)
Lemma sumbool_of_boolET (b: bool) (h: b) :
  Sumbool.sumbool_of_bool b = left h.
Proof. by move: h; rewrite /is_true => ?; subst. Qed.

Lemma sumbool_of_boolEF (b: bool) (h: b = false) :
  Sumbool.sumbool_of_bool b = right h.
Proof. by move: h; rewrite /is_true => ?; subst. Qed.

(* ------------------------------------------------------------------------- *)
Definition funname := positive.

Definition get_fundef {T} (p: seq (funname * T)) (f: funname) :=
  assoc p f.

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

Definition lprod ts tr :=
  foldr (fun t tr => t -> tr) tr ts.

Fixpoint ltuple (ts:list Type) : Type :=
  match ts with
  | [::]   => unit
  | [::t1] => t1
  | t1::ts => t1 * ltuple ts
  end.

Notation "(:: x , .. , y & z )" := (pair x .. (pair y z) ..) (only parsing).

Fixpoint merge_tuple (l1 l2: list Type) : ltuple l1 -> ltuple l2 -> ltuple (l1 ++ l2) :=
  match l1 return ltuple l1 -> ltuple l2 -> ltuple (l1 ++ l2) with
  | [::] => fun _ p => p
  | t1 :: l1 =>
    let rec := @merge_tuple l1 l2 in
    match l1 return (ltuple l1 -> ltuple l2 -> ltuple (l1 ++ l2)) ->
                    ltuple (t1::l1) -> ltuple l2 -> ltuple (t1 :: l1 ++ l2) with
    | [::] => fun _ (x:t1) =>
      match l2 return ltuple l2 -> ltuple (t1::l2) with
      | [::] => fun _ => x
      | t2::l2    => fun (p:ltuple (t2::l2)) => (x, p)
      end
    | t1' :: l1' => fun rec (x:t1 * ltuple (t1'::l1')) p =>
      (x.1, rec x.2 p)
    end rec
   end.

(* ------------------------------------------------------------------------- *)
  Lemma neq_sym (T: eqType) (x y: T) :
    (x != y) = (y != x).
  Proof. apply/eqP; case: eqP => //; exact: not_eq_sym. Qed.

(* ------------------------------------------------------------------------- *)
Lemma nth_not_default T x0 (s:seq T) n x :
  nth x0 s n = x ->
  x0 <> x ->
  (n < size s)%nat.
Proof.
  move=> hnth hneq.
  rewrite ltnNge; apply /negP => hle.
  by rewrite nth_default in hnth.
Qed.

Lemma all_behead {A} {p : A -> bool} {xs : seq A} :
  all p xs -> all p (behead xs).
Proof.
  case: xs => // x xs.
  by move=> /andP [] _.
Qed.

Lemma all2_behead {A B} {p: A -> B -> bool} {xs: seq A} {ys: seq B} :
  all2 p xs ys
  -> all2 p (behead xs) (behead ys).
Proof.
  case: xs; case: ys => //= y ys x xs.
  by move=> /andP [] _.
Qed.

Lemma notin_cons (T : eqType) (x y : T) (s : seq T) :
  (x \notin y :: s) = (x != y) && (x \notin s).
Proof. by rewrite in_cons negb_or. Qed.

(* Convert [ C |- uniq xs -> P ] into
   [ C, ? : x0 <> x1, ? : x0 <> x2, ... |- P ]. *)
Ltac t_elim_uniq :=
  repeat (
    move=> /andP [];
    repeat (rewrite notin_cons; move=> /andP [] /eqP ?);
    move=> _
  );
  move=> _.

Inductive and6 (P1 P2 P3 P4 P5 P6 : Prop) : Prop :=
  And6 of P1 & P2 & P3 & P4 & P5 & P6.

Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" :=
  (and6 P1 P2 P3 P4 P5 P6) : type_scope.

Tactic Notation "have!" ":= " constr(x) :=
  let h := fresh "h" in
  (assert (h := x); move: h).

Tactic Notation "have!" simple_intropattern(ip) ":= " constr(x) :=
  let h := fresh "h" in
  (assert (h := x); move: h => ip).


Require Export Iron.Language.SimpleData.Exp.

(* Type Judgement assigns a type to an expression. *)
Inductive TYPE : defs -> tyenv -> exp -> ty -> Prop :=
 (* Variables *)
 | TYVar
   :  forall ds te i t
   ,  get i te = Some t
   -> TYPE ds te (XVar i) t

 (* Lambda Abstraction *)
 | TYLam
   :  forall ds te x t1 t2
   ,  TYPE ds (te :> t1) x            t2
   -> TYPE ds te         (XLam t1 x) (TFun t1 t2)

 (* Applications *)
 | TYApp
   :  forall ds te x1 x2 t1 t2
   ,  TYPE ds te x1           (TFun t1 t2)
   -> TYPE ds te x2           t1
   -> TYPE ds te (XApp x1 x2) t2

 (* Data Constructors *)
 | TYCon
   :  forall ds te xs dc dcs tsArgs tc
   ,  getDataDef dc ds = Some (DefData     dc tsArgs (TCon tc))
   -> getTypeDef tc ds = Some (DefDataType tc dcs)
   -> In dc dcs
   -> Forall2 (TYPE ds te) xs tsArgs
   -> TYPE ds te (XCon dc xs) (TCon tc)

 (* Case Expressions *)
 | TYCase
   :  forall ds te xObj tcPat tResult alts dcs

      (* check types of expression and alternatives *)
   ,  TYPE ds te xObj (TCon tcPat)
   -> Forall (fun alt => TYPEA ds te alt (TCon tcPat) tResult) alts

      (* there must be at least one alternative *)
   -> length alts > 0

      (* all data cons must have a corresponding alternative *)
   -> getTypeDef tcPat ds = Some (DefDataType tcPat dcs)
   -> Forall (fun dc => In dc (map dcOfAlt alts)) dcs

   -> TYPE ds te (XCase xObj alts) tResult

with TYPEA : defs -> tyenv -> alt -> ty -> ty -> Prop :=
 (* Case Alternatives *)
 | TYAlt
   :  forall ds te x1 t1 dc tsArgs tResult
   ,  getDataDef dc ds = Some (DefData dc tsArgs tResult)
   -> TYPE  ds (te >< tsArgs) x1 t1
   -> TYPEA ds te (AAlt dc tsArgs x1) tResult t1.

Hint Constructors TYPE.
Hint Constructors TYPEA.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TYPE  _ _ (XVar  _)    _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XLam  _ _)  _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XApp  _ _)  _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XCon  _ _)  _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XCase _ _)  _    |- _ ] => inverts H
   | [ H: TYPEA _ _ (AAlt _ _ _) _ _  |- _ ] => inverts H
   end).

(********************************************************************)
(* Forms of values.
   If we know the type of a value,
   then we know the form of that value. *)
Lemma value_lam
 :  forall x ds te t1 t2
 ,  value x
 -> TYPE ds te x (TFun t1 t2)
 -> (exists t x', x = XLam t x').
Proof.
 intros. destruct x; burn.
Qed.
Hint Resolve value_lam.

(********************************************************************)
(* A well typed expression is well formed *)
Theorem type_wfX
 :  forall ds te x t
 ,  TYPE ds te x t
 -> wfX te x.
Proof.
 intros. gen ds te t.
 induction x using exp_mutind with
  (PA := fun a => forall ds te t1 t2
      ,  TYPEA ds te a t1 t2
      -> wfA te a)
  ; intros; inverts_type; eauto.

 Case "XCon".
  apply WfX_XCon. repeat nforall. intros.
  have HT: (exists t, TYPE ds te x t).
  spec H H0 ds te.
  destruct HT as [t].
  burn.

 Case "XCase".
  eapply WfX_XCase; repeat nforall; burn.
Qed.
Hint Resolve type_wfX.

(* Weakening Type Env in Type Judgement.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma type_tyenv_insert
 :  forall ds te ix x t1 t2
 ,  TYPE ds te x t1
 -> TYPE ds (insert ix t2 te) (liftX 1 ix x) t1.
Proof.
 intros. gen ix ds te t1.
 induction x using exp_mutind with
  (PA := fun a => forall ix ds te t3 t4
      ,  TYPEA ds te a t3 t4
      -> TYPEA ds (insert ix t2 te) (liftA 1 ix a) t3 t4)
  ; intros; inverts_type; burn; simpl.

 Case "XVar".
  lift_cases; burn.

 Case "XLam".
  apply TYLam.
  rewrite insert_rewind. auto.

 Case "XCon".
  eapply TYCon; burn.
   apply (Forall2_map_left (TYPE ds (insert ix t2 te))).
   apply (Forall2_impl_in  (TYPE ds te)); eauto.
   nforall. eauto.

 Case "XCase".
  eapply TYCase; eauto.
   apply Forall_map.
   apply (Forall_impl_in (fun a => TYPEA ds te a (TCon tcPat) t1)); eauto.
   repeat nforall. burn.

  rewrite map_length; auto.

  norm.
   intros. rename x0 into d.
   rewrite map_map. unfold Basics.compose.
   eapply map_exists_in.
   have (In d (map dcOfAlt aa)).
   assert (exists a, dcOfAlt a = d /\ In a aa).
    eapply map_in_exists. auto.
   shift a. rip.
   eapply dcOfAlt_liftA.

 Case "XAlt".
  eapply TYAlt; eauto.
  rewrite insert_app. auto.
Qed.

(* We can push a new type onto the environment stack provided
   we lift references to existing types across the new one. *)
Lemma type_tyenv_weaken1
 :  forall ds te x t1 t2
 ,  TYPE ds te x t1
 -> TYPE ds (te :> t2) (liftX 1 0 x) t1.
Proof.
 intros.
 rrwrite (te :> t2 = insert 0 t2 te).
 burn using type_tyenv_insert.
Qed.

(* We can several new types onto the environment stack provided
   we lift referenes to existing types across the new one. *)
Lemma type_tyenv_weaken_append
 :  forall ds te te' x t1
 ,  TYPE ds te x t1
 -> TYPE ds (te >< te') (liftX (length te') 0 x) t1.
Proof.
 intros.
 induction te'; simpl.
 rewrite liftX_zero; auto.
 rewrite <- nat_plus_one.
 rrwrite (length te' + 1 = 1 + length te').
 rewrite <- liftX_plus.
 eapply type_tyenv_weaken1. auto.
Qed.


Lemma bottom_winning_strategy {p} {s : strategy bottom p}
 : winning_strategy s <-> p = player_O.
Proof.
  unfold winning_strategy.
  setoid_rewrite bottom_play_won_by.
  firstorder.
  eapply H.
  apply bottom_player_follows_strategy.
  Unshelve.
  exact trivial_play.
Qed.


Require Export SpecializedCategory Group.
Require Import Notations ComputableCategory SetCategory.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Ltac destruct_first_if_not_second a b :=
  (constr_eq a b; fail 1) || (let H := fresh in set (H := a : unit) in *; destruct H).

Ltac destruct_singleton_constructor c :=
  let t := type of c in
  repeat match goal with
           | [ H : t |- _ ] => destruct H
           | [ H : context[?e] |- _ ] => destruct_first_if_not_second e c
           | [ |- context[?e] ] => destruct_first_if_not_second e c
         end.

Ltac destruct_units := destruct_singleton_constructor tt.
Ltac destruct_Trues := destruct_singleton_constructor I.

Section as_category.
  Definition CategoryOfGroup (G : Group) : SpecializedCategory unit.
    refine (@Build_SpecializedCategory unit
                                       (fun _ _ => G)
                                       (fun _ => @GroupIdentity G)
                                       (fun _ _ _ => @GroupOperation G)
                                       _
                                       _
                                       _);
    abstract (destruct G; intuition).
  Defined.
End as_category.

Coercion CategoryOfGroup : Group >-> SpecializedCategory.

Section category_of_groups.
  Definition GroupCat : SpecializedCategory Group
    := Eval unfold ComputableCategory in ComputableCategory _ CategoryOfGroup.
End category_of_groups.

Section forgetful_functor.
  Definition GroupForgetfulFunctor : SpecializedFunctor GroupCat TypeCat.
    refine (Build_SpecializedFunctor GroupCat TypeCat
                                     GroupObjects
                                     (fun s d m => MorphismOf m (s := tt) (d := tt))
                                     _
                                     _);
    simpl; abstract (intros; destruct_units; reflexivity).
  Defined.
End forgetful_functor.


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

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a}(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive color  :=
  | Blue : color
  | White : color
  | Red : color .
Axiom color_WhyType : WhyType color.
Existing Instance color_WhyType.

(* Why3 assumption *)
Definition monochrome(a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color): Prop :=
  forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) -> ((map.Map.get a k) = c).

Parameter nb_occ: (map.Map.map Z color) -> Z -> Z -> color -> Z.

Axiom nb_occ_null : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  (j <= i)%Z -> ((nb_occ a i j c) = 0%Z).

Axiom nb_occ_add_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  ((i < j)%Z /\ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a i j
  c) = ((nb_occ a i (j - 1%Z)%Z c) + 1%Z)%Z).

Axiom nb_occ_add_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (c:color), ((i < j)%Z /\ ~ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a
  i j c) = (nb_occ a i (j - 1%Z)%Z c)).

Axiom nb_occ_split : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ a i k c) = ((nb_occ a i j
  c) + (nb_occ a j k c))%Z).

Axiom nb_occ_store_outside_up : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (k:Z) (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ (map.Map.set a k c)
  i j c) = (nb_occ a i j c)).

Axiom nb_occ_store_outside_down : forall (a:(map.Map.map Z color)) (i:Z)
  (j:Z) (k:Z) (c:color), ((k < i)%Z /\ (i <= j)%Z) -> ((nb_occ (map.Map.set a
  k c) i j c) = (nb_occ a i j c)).

Axiom nb_occ_store_eq_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= k)%Z /\ (k < j)%Z) -> (((map.Map.get a k) = c) ->
  ((nb_occ (map.Map.set a k c) i j c) = (nb_occ a i j c))).

Open Scope Z_scope.
Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.95.1," timelimit 15.

(* Why3 goal *)
Theorem nb_occ_store_eq_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (k:Z) (c:color), ((i <= k)%Z /\ (k < j)%Z) -> ((~ ((map.Map.get a
  k) = c)) -> ((nb_occ (map.Map.set a k c) i j c) = ((nb_occ a i j
  c) + 1%Z)%Z)).
intros a i j k c (Hik & Hkj) H.
rewrite nb_occ_split with (j:=k); auto with zarith.
rewrite nb_occ_store_outside_up; auto with zarith.
rewrite nb_occ_split with (i:=k) (j:=k+1); auto with zarith.
rewrite nb_occ_split with (i:=i) (j:=k) (k:=j); auto with zarith.
rewrite nb_occ_split with (i:=k) (j:=k+1) (k:=j); auto with zarith.
rewrite nb_occ_store_outside_down with (i:=k+1); auto with zarith.
ae.
Qed.


Inductive rgb : Type :=
  | red
  | green
  | blue.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.
Check Playground.b : rgb.
Check b : bool.


From demo Require Import simplified_iris.

Section proof.
Context `{!heapGS Σ}.

Theorem coq_swap (P Q: Prop):
  P ∧ Q → Q ∧ P.
Proof.
  intros H.
  destruct H as [HP HQ].
  split.
  - apply HQ.
  - apply HP.
Qed.

Theorem prove_swap_the_hard_way x y :
  x ↦ #0 ∗ y ↦ #3 ⊢ y ↦ #3 ∗ x ↦ #0.
Proof.
  iIntros "H".
  iDestruct "H" as "[Hx Hy]".
  iSplitL "Hy".
  - iApply "Hy".
  - iApply "Hx".
Qed.

Theorem prove_swap_the_easy_way x y :
  x ↦ #0 ∗ y ↦ #3 ⊢ y ↦ #3 ∗ x ↦ #0.
Proof.
  iIntros "[Hx Hy]".
  iFrame.
Qed.

Theorem ex01 (x y: loc) :
  x ↦ #0 ∗ y ↦ #0 ⊢ WP #x <- #y;; #y <- #x {{ λ _, x ↦ #y ∗ y ↦ #x }}.
Proof.
  iIntros "[Hx Hy]".
  wp_bind (Store _ _).
  iApply wp_frame.
  iSplitL "Hx".
  { iApply (wp_store_axiom with "Hx"). }
  simpl. iIntros (?) "Hx"; wp_pures.
  iApply wp_frame.
  iSplitL "Hy".
  { iApply (wp_store_axiom with "Hy"). }
  simpl. iIntros (?) "Hy".
  iFrame.
Qed.

End proof.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult lv0 (Succ Zero)) (plus (mult lv1 (Succ lv2)) (Succ lv2))).
Admitted.
QuickChick conj5synthconj2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D0 D : Universe, ((wd_ B A /\ (wd_ A D0 /\ (wd_ B D0 /\ (wd_ B C /\ (wd_ A C /\ (wd_ B D /\ (wd_ D B /\ (col_ D B A /\ col_ B D0 D)))))))) -> col_ B A D0)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma per_mono_eq_congr {p} :
  forall lib (eqa eqb : per(p)),
  eq_term_equals eqa eqb
  -> (mono_equality lib eqa  <=> mono_equality lib eqb).
Proof.
  introv; unfold eq_term_equals, mono_equality, cofinite_subst_fapprox_eqc,
    subst_fix_eqc; split; spc;
  dtiffs2;
  match goal with
  [ H : forall _ _ , _  |- _] => (apply H)
  end; eauto.
Qed.

(* !! Move to eq_rel.v *)
Hint Immediate t_iff_refl.

Lemma eq_term_equals_per_mono_eq_if {p} :
  forall lib (eqa1 eqa2 : per(p)),
    eq_term_equals eqa1 eqa2
    -> eq_term_equals (per_mono_eq lib eqa1) (per_mono_eq lib eqa2).
Proof.
  introv eqt.
  unfold eq_term_equals.
  allunfold @per_mono_eq. introv.
  apply (per_mono_eq_congr lib) in eqt.
  rw eqt. auto.
Qed.

Lemma per_mono_eq_symmetric {p} :
  forall lib (eq : per(p)) t1 t2,
    term_equality_symmetric eq
    -> per_mono_eq lib eq t1 t2
    -> per_mono_eq lib eq t2 t1.
Proof.
  introv tes per.
  allunfold @per_mono_eq; exrepnd; dands; allrw; try (complete sp).
Qed.

Lemma per_mono_eq_transitive {p} :
  forall lib (eq : per(p)) t1 t2 t3,
    term_equality_transitive eq
    -> per_mono_eq lib eq t1 t2
    -> per_mono_eq lib eq t2 t3
    -> per_mono_eq lib eq t1 t3.
Proof.
  introv tet per1 per2.
  allunfold @per_mono_eq; exrepnd.
  dands; try (allrw; complete sp).
Qed.

Lemma per_mono_eq_cequiv {p} :
  forall lib (eq : per(p)) t1 t2,
    term_equality_respecting lib eq
    -> cequivc lib t1 t2
    -> per_mono_eq lib eq t1 t1
    -> per_mono_eq lib eq t1 t2.
Proof.
  introv res ceq per.
  allunfold @per_mono_eq; repnd; dands; auto.
  GC; try (spcast; apply cequivc_axiom with (t := t1); sp).
Qed.

Lemma close_type_system_mono {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A1 A2 eqa,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_mono A1)
    -> computes_to_valc lib T' (mkc_mono A2)
    -> close lib ts A1 A2 eqa
    -> type_sys_props lib (close lib ts) A1 A2 eqa
    -> (forall t t' : CTerm, eq t t' <=> per_mono_eq lib eqa t t')
    -> per_mono lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv tysys dou c1 c2 cla reca eqiff per.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  - SCase "uniquely_valued".
    dclose_lr.

    + SSCase "CL_mono".
      clear per.
      allunfold @per_mono; exrepd.
      unfold eq_term_equals; intros.
      allrw.
      ccomputes_to_eqval.
      revert t1 t2; rw @fold_eq_term_equals.
      apply eq_term_equals_per_mono_eq_if.
      onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
      generalize (uv A3 eqa0); sp.

  - SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_mono;
    clear per;
    allunfold @per_mono; exrepd;
    unfold per_mono;
    ccomputes_to_eqval.

    + exists A1 A3 eqa0; sp; spcast; sp.
      apply eq_term_equals_trans with (eq2 := eq); sp.
      apply eq_term_equals_sym; sp.

  - SCase "type_value_respecting"; repdors; subst;
    apply CL_mono; unfold per_mono.

    (* 1 *)
    generalize (cequivc_mkc_mono lib T T3 A1); introv k; repeat (autodimp k hyp); exrepnd.
    exists A1 b eqa; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr A1 b); sp.

    (* 2 *)
    generalize (cequivc_mkc_mono lib T' T3 A2); introv k; repeat (autodimp k hyp); exrepnd.
    exists A2 b eqa; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tyvr A2 b); sp.

  - SCase "term_symmetric".
    unfold term_equality_symmetric; introv eqt.
    rw eqiff in eqt; rw eqiff.
    apply per_mono_eq_symmetric; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt; sp.

  - SCase "term_transitive".
    unfold term_equality_transitive; introv eqt1 eqt2.
    rw eqiff in eqt1; rw eqiff in eqt2; rw eqiff.
    apply @per_mono_eq_transitive with (t2 := t2); sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt; sp.

  - SCase "term_value_respecting".
    unfold term_equality_respecting; introv eqt ceq.
    rw eqiff in eqt; rw eqiff.
    spcast.
    apply per_mono_eq_cequiv; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt; sp.

  - SCase "type_gsymmetric".
    repdors; subst; split; sp; dclose_lr;
    apply CL_mono;
    clear per;
    allunfold @per_mono; exrepd;
    ccomputes_to_eqval;
    unfold per_mono.

    (* 1 *)
    exists A3 A1 eqa0; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tygs A1 A3 eqa0); intro k; repeat (autodimp k hyp).
    rw <- k; sp.

    (* 2 *)
    exists A1 A0 eqa0; sp; spcast; sp.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
    generalize (tygs A1 A0 eqa0); intro k; repeat (autodimp k hyp).
    rw k; sp.

  - SCase "type_gtransitive"; sp.

  - SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_mono lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_mono lib (close lib ts) T' T4 eq2));
    allunfold @per_mono; exrepd;
    ccomputes_to_eqval.

    + dands; apply CL_mono; unfold per_mono.

      * exists A4 A3 eqa1; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A1 A4 A3 eqa1 eqa0); sp.

      * exists A4 A3 eqa0; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A1 A4 A3 eqa1 eqa0); sp.

    + dands; apply CL_mono; unfold per_mono.

      * exists A4 A3 eqa1; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A2 A4 A3 eqa1 eqa0); sp.

      * exists A4 A3 eqa0; sp; spcast; sp.
        onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
        generalize (tymt A2 A4 A3 eqa1 eqa0); sp.
Qed.


Require Import Coq.Lists.List.
Require Import Crypto.Reflection.Syntax.

Local Open Scope core_scope.
Local Notation eta x := (fst x, snd x).

Section language.
  Context {base_type_code : Type}
          {Name : Type}.

  Section monad.
    Context (MName : Type) (force : MName -> option Name).
    Fixpoint split_mnames
             (t : flat_type base_type_code) (ls : list MName)
      : option (interp_flat_type (fun _ => Name) t) * list MName
      := match t return option (@interp_flat_type base_type_code (fun _ => Name) t) * _ with
         | Tbase _
           => match ls with
              | cons n ls'
                => match force n with
                   | Some n => (Some n, ls')
                   | None => (None, ls')
                   end
              | nil => (None, nil)
              end
         | Unit => (Some tt, ls)
         | Prod A B
           => let '(a, ls) := eta (@split_mnames A ls) in
              let '(b, ls) := eta (@split_mnames B ls) in
              (match a, b with
               | Some a', Some b' => Some (a', b')
               | _, _ => None
               end,
               ls)
         end.
    Definition mname_list_unique (ls : list MName) : Prop
      := forall k n,
        List.In (Some n) (firstn k (List.map force ls))
        -> List.In (Some n) (skipn k (List.map force ls))
        -> False.
  End monad.
  Definition split_onames := @split_mnames (option Name) (fun x => x).
  Definition split_names := @split_mnames Name (@Some _).

  Definition oname_list_unique (ls : list (option Name)) : Prop
    := mname_list_unique (option Name) (fun x => x) ls.
  Definition name_list_unique (ls : list Name) : Prop
    := oname_list_unique (List.map (@Some Name) ls).
End language.

Global Arguments split_mnames {_ _ MName} force _ _, {_ _} MName force _ _.
Global Arguments split_onames {_ _} _ _.
Global Arguments split_names {_ _} _ _.
Global Arguments mname_list_unique {_ MName} force ls, {_} MName force ls.
Global Arguments oname_list_unique {_} ls.
Global Arguments name_list_unique {_} ls.