(**
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.


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.