(** Typeclass for decidable propositions *)

Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Lists.List.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.HProp.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith_dec.
Require Import Coq.NArith.BinNat.

Local Open Scope type_scope.

Class Decidable (P : Prop) := dec : {P} + {~P}.
Arguments dec _%type_scope {_}.
Notation DecidableRel R := (forall x y, Decidable (R x y)).

Global Instance hprop_eq_dec {A} `{DecidableRel (@eq A)} : IsHPropRel (@eq A) | 10.
Proof. repeat intro; apply UIP_dec; trivial with nocore. Qed.

Global Instance eq_dec_hprop {A} {x y : A} {hp : IsHProp A} : Decidable (@eq A x y) | 5.
Proof. left; auto. Qed.

Ltac no_equalities_about x0 y0 :=
  lazymatch goal with
  | [ H' : x0 = y0 |- _ ] => fail
  | [ H' : y0 = x0 |- _ ] => fail
  | [ H' : x0 <> y0 |- _ ] => fail
  | [ H' : y0 <> x0 |- _ ] => fail
  | _ => idtac
  end.

Ltac destruct_decidable_step :=
  match goal with
  | [ H : Decidable _ |- _ ] => destruct H
  | [ H : forall x y : ?A, Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H x0 y0)
  | [ H : forall a0 (x y : _), Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H _ x0 y0)
  end.
Ltac destruct_decidable := repeat destruct_decidable_step.

Ltac pre_decide_destruct_sigma_step :=
  match goal with
  | [ H : sigT _ |- _ ] => destruct H
  | [ H : sig _ |- _ ] => destruct H
  | [ H : ex _ |- _ ] => destruct H
  end.
Ltac pre_decide_destruct_sigma := repeat pre_decide_destruct_sigma_step.

Ltac pre_decide :=
  repeat (intros
          || destruct_decidable
          || split
          || pre_decide_destruct_sigma
          || unfold Decidable in *
          || hnf).

(** Put the [subst] and reasoning about equalities after the [left]
    and [right]; opaque equality proofs should not block decidability
    proofs. *)
Ltac post_decide :=
  repeat (intros
          || subst
          || pre_hprop).

Ltac solve_decidable_transparent_with tac :=
  pre_decide;
  try solve [ left; abstract (post_decide; tac)
            | right; abstract (post_decide; tac)
            | decide equality; eauto with nocore ].

Ltac solve_decidable_transparent := solve_decidable_transparent_with firstorder.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Local Hint Extern 1 => progress inversion_sigma : core.

Global Instance dec_True : Decidable True | 10 := left I.
Global Instance dec_False : Decidable False | 10 := right (fun x => x).
Global Instance dec_or {A B} `{Decidable A, Decidable B} : Decidable (A \/ B) | 10. exact _. Defined.
Global Instance dec_and {A B} `{Decidable A, Decidable B} : Decidable (A /\ B) | 10. exact _. Defined.
Global Instance dec_impl {A B} `{Decidable (B \/ ~A)} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_impl_simple {A B} `{Decidable A, Decidable B} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_iff {A B} `{Decidable A, Decidable B} : Decidable (A <-> B) | 10. exact _. Defined.
Lemma dec_not {A} `{Decidable A} : Decidable (~A).
Proof. solve_decidable_transparent. Defined.
(** Disallow infinite loops of dec_not *)
Global Hint Extern 0 (Decidable (~?A)) => apply (@dec_not A) : typeclass_instances.
Global Instance dec_eq_unit : DecidableRel (@eq unit) | 10. exact _. Defined.
Global Instance dec_eq_bool : DecidableRel (@eq bool) | 10. exact _. Defined.
Global Instance dec_eq_Empty_set : DecidableRel (@eq Empty_set) | 10. exact _. Defined.
Global Instance dec_eq_prod {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A * B)) | 10. exact _. Defined.
Global Instance dec_eq_option {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (option A)) | 10. exact _. Defined.
Global Instance dec_eq_list {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (list A)) | 10. exact _. Defined.
Global Instance dec_eq_list_nil_r {A} {ls} : Decidable (ls = @nil A) | 10.
Proof. destruct ls; [ left; reflexivity | right; abstract congruence ]. Defined.
Global Instance dec_eq_list_nil_l {A} {ls} : Decidable (@nil A = ls) | 10.
Proof. destruct ls; [ left; reflexivity | right; abstract congruence ]. Defined.
Global Instance dec_eq_sum {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A + B)) | 10. exact _. Defined.
Global Instance dec_eq_sigT_hprop {A P} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sigT A P)) | 10. exact _. Defined.
Global Instance dec_eq_sig_hprop {A} {P : A -> Prop} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sig A P)) | 10. exact _. Defined.
Global Instance dec_eq_comparison : DecidableRel (@eq comparison) | 10. exact _. Defined.

Global Instance dec_eq_nat : DecidableRel (@eq nat) | 10. exact _. Defined.
Global Instance dec_le_nat : DecidableRel le := Compare_dec.le_dec.
Global Instance dec_lt_nat : DecidableRel lt := Compare_dec.lt_dec.
Global Instance dec_ge_nat : DecidableRel ge := Compare_dec.ge_dec.
Global Instance dec_gt_nat : DecidableRel gt := Compare_dec.gt_dec.

Global Instance dec_eq_N : DecidableRel (@eq N) | 10 := N.eq_dec.

Global Instance dec_eq_Z : DecidableRel (@eq Z) | 10 := Z.eq_dec.
Global Instance dec_lt_Z : DecidableRel BinInt.Z.lt := ZArith_dec.Z_lt_dec.
Global Instance dec_le_Z : DecidableRel BinInt.Z.le := ZArith_dec.Z_le_dec.
Global Instance dec_gt_Z : DecidableRel BinInt.Z.gt := ZArith_dec.Z_gt_dec.
Global Instance dec_ge_Z : DecidableRel BinInt.Z.ge := ZArith_dec.Z_ge_dec.

Global Instance dec_Forall {A P} {HD : forall x : A, Decidable (P x)} {ls}
  : Decidable (Forall P ls) | 10.
Proof.
  induction ls as [|x xs IHxs]; [ left | destruct (HD x), IHxs; [ left | right.. ] ];
    [ constructor; assumption | constructor; assumption | intro Hn.. ];
    clear HD;
    try abstract (inversion Hn; subst; tauto).
Defined.
Global Instance dec_Exists {A P} {HD : forall x : A, Decidable (P x)} {ls}
  : Decidable (Exists P ls) | 10.
Proof.
  induction ls as [|x xs IHxs]; [ right | destruct (HD x), IHxs; [ left.. | right ] ];
    [ intro Hn | constructor; assumption.. | intro Hn ];
    clear HD;
    try abstract (inversion Hn; subst; tauto).
Defined.

Global Instance dec_match_pair {A B} {P : A -> B -> Prop} {x : A * B}
       {HD : Decidable (P (fst x) (snd x))}
  : Decidable (let '(a, b) := x in P a b) | 1.
Proof. edestruct (_ : _ * _); assumption. Defined.

Global Instance dec_if_bool {b : bool} {A B} {HA : Decidable A} {HB : Decidable B}
  : Decidable (if b then A else B) | 10
  := if b return Decidable (if b then A else B)
     then HA
     else HB.

Lemma not_not P {d:Decidable P} : not (not P) <-> P.
Proof. destruct (dec P); intuition. Qed.

Global Instance dec_ex_forall_not : forall T (P:T->Prop) {d:Decidable (exists b, P b)}, Decidable (forall b, ~ P b).
Proof.
  intros T P d.
  destruct (dec (~ exists b, P b)) as [Hd|Hd]; [left|right];
    [abstract eauto | let Hd := Hd in abstract (rewrite not_not in Hd by eauto; destruct Hd; eauto) ].
Defined.

Lemma eqsig_eq {T} {U} {Udec:DecidableRel (@eq U)} (f g:T->U) (x x':T) pf pf' :
  (exist (fun x => f x = g x) x pf) = (exist (fun x => f x = g x) x' pf') <-> (x = x').
Proof. apply path_sig_hprop_iff; auto using UIP_dec, Udec. Qed.

Lemma Decidable_respects_iff A B (H : A <-> B) : (Decidable A -> Decidable B) * (Decidable B -> Decidable A).
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_impl A B (H : A <-> B) : Decidable A -> Decidable B.
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_flip_impl A B (H : A <-> B) : Decidable B -> Decidable A.
Proof. solve_decidable_transparent. Defined.

Global Instance dec_eq_positive : DecidableRel (@eq BinNums.positive) | 10 := BinPos.Pos.eq_dec.
Global Instance dec_lt_positive : DecidableRel BinPos.Pos.lt.
Proof. eauto using Decidable_iff_to_impl, Pos.ltb_lt with typeclass_instances. Defined.
Global Instance dec_le_positive : DecidableRel BinPos.Pos.le.
Proof. eauto using Decidable_iff_to_impl, Pos.leb_le with typeclass_instances. Defined.
Global Instance dec_gt_positive : DecidableRel BinPos.Pos.gt.
Proof. eauto using Decidable_iff_to_flip_impl, Pos.gt_lt_iff with typeclass_instances. Defined.
Global Instance dec_ge_positive : DecidableRel BinPos.Pos.ge.
Proof. eauto using Decidable_iff_to_flip_impl, Pos.ge_le_iff with typeclass_instances. Defined.

Lemma dec_of_semidec {P : Prop} (H : option P) (H_complete : H = None -> ~P) : Decidable P.
Proof. destruct H; [ left; assumption | right; apply H_complete, eq_refl ]. Defined.

Lemma dec_rel_of_semidec_rel {A} {R : A -> A -> Prop} (H : forall x y, option (R x y))
      (H_complete : forall x y, H x y = None -> ~R x y) : DecidableRel R.
Proof. eauto using dec_of_semidec. Defined.

Lemma dec_of_bool_dec {P : Prop} (b : bool) (Hbl : b = true -> P) (Hlb : P -> b = true)
  : Decidable P.
Proof. destruct b; [ left; apply Hbl; reflexivity | right; intro p; apply Bool.diff_false_true, Hlb, p ]. Defined.

Definition bool_of_dec (P : Prop) {H : Decidable P} : bool := if H then true else false.
Lemma bp_of_dec (P : Prop) {H : Decidable P} : bool_of_dec P = true -> P.
Proof. cbv [bool_of_dec]; destruct H; [ trivial with nocore | abstract congruence ]. Defined.
Lemma pb_of_dec (P : Prop) {H : Decidable P} : P -> bool_of_dec P = true.
Proof. cbv [bool_of_dec]; destruct H; [ reflexivity | abstract tauto ]. Defined.

Lemma dec_rel_of_bool_dec_rel {A} {R : A -> A -> Prop} (b : A -> A -> bool)
      (Hbl : forall x y, b x y = true -> R x y) (Hlb : forall x y, R x y -> b x y = true)
  : DecidableRel R.
Proof. eauto using dec_of_bool_dec. Defined.

Definition bool_rel_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R} : A -> A -> bool
  := fun x y => if H x y then true else false.
Lemma br_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R}
  : forall x y, bool_rel_of_dec_rel R x y = true -> R x y.
Proof. cbv [bool_rel_of_dec_rel]; intros x y; destruct (H x y); [ trivial with nocore | abstract congruence ]. Defined.
Lemma rb_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R}
  : forall x y, R x y -> bool_rel_of_dec_rel R x y = true.
Proof. cbv [bool_rel_of_dec_rel]; intros x y; destruct (H x y); [ reflexivity | abstract tauto ]. Defined.

Lemma dec_bool : forall {P} {Pdec:Decidable P}, (if dec P then true else false) = true -> P.
Proof. intros. destruct dec; solve [ auto | discriminate ]. Qed.

Ltac vm_decide_no_check := apply dec_bool; vm_cast_no_check (eq_refl true).
Ltac lazy_decide_no_check := apply dec_bool; exact_no_check (eq_refl true).

Ltac vm_decide := abstract vm_decide_no_check.
Ltac lazy_decide := abstract lazy_decide_no_check.

(** For dubious compatibility with [eauto using]. *)
Global Hint Extern 2 (Decidable _) => progress unfold Decidable : typeclass_instances core.

Definition cast_if_eq {T} `{DecidableRel (@eq T)} {P} (t t' : T) (v : P t) : option (P t')
  := match dec (t = t'), dec (t' = t') with
     | left pf, left pf' => Some (eq_rect _ P v _ (eq_trans pf (eq_sym pf')))
     | _, right pf' => match pf' eq_refl with end
     | right pf, _ => None
     end.

Lemma cast_if_eq_refl {T H P} t v : @cast_if_eq T H P t t v = Some v.
Proof.
  compute; clear; destruct (H t t) as [ [] |e];
    [ reflexivity | destruct (e eq_refl) ].
Qed.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Import String axiomatic_simple.

Section gcd.
Context `{EnvSpec K}.
Hint Extern 10 (Some Readable ⊆ _) => transitivity (Some Writable): core.
Hint Extern 0 (perm_locked _ = _) =>
  apply perm_Readable_locked; auto : typeclass_instances.

Hint Resolve ax_load' ax_var' assert_memext_l' assert_eval_int_cast_self'
  assert_memext_r' assert_and_l assert_singleton_eval assert_int_typed_eval
  assert_eval_singleton_r assert_eval_singleton_l assert_and_intro : exec.
Ltac exec :=
  repeat match goal with A := _ : assert _ |- _ => progress unfold A end;
  simpl; eauto 20 with exec.

Definition gcd_stmt : stmt K :=
  "l" :; if{load (var 1)} local{uintT} (
    !(var 2 ::= (
        var 0 ::= load (var 1) .{ArithOp ModOp} load (var 2),,
        var 1 ::= load (var 2),,
        load (var 0)));;
    goto "l"
  ) else skip.
Lemma gcd_typed : (∅,∅,[uintT%T;uintT%T]) ⊢ gcd_stmt : (false,None).
Proof.
  change false with (true && false).
  repeat (apply SLocal_typed || typed_constructor
                             || constructor); try set_solver.
  apply base_binop_type_of_sound; simpl.
  by rewrite (idemp_L _), int_promote_int.
Qed.
Lemma gcd_correct Γ δ R J T C y z μ1 γ1 μ2 γ2 :
  sep_valid γ1 → Some Writable ⊆ perm_kind γ1 →
  sep_valid γ2 → Some Writable ⊆ perm_kind γ2 →
  J "l"%string ≡{Γ,δ} (∃ y' z',
    ⌜ Z.gcd y' z' = Z.gcd y z ⌝%Z ★
    var 0 ↦{μ1,γ1} #intV{uintT} y' : uintT ★
    var 1 ↦{μ2,γ2} #intV{uintT} z' : uintT)%A →
  Γ\ δ\ R\ J\ T\ C ⊨ₛ
    {{ var 0 ↦{μ1,γ1} #intV{uintT} y : uintT ★
       var 1 ↦{μ2,γ2} #intV{uintT} z : uintT }}
      gcd_stmt
    {{ var 0 ↦{μ1,γ1} #intV{uintT} (Z.gcd y z) : uintT ★
       var 1 ↦{μ2,γ2} #intV{uintT} 0 : uintT }}.
Proof.
  intros ???? HJ; eapply ax_comp.
  { eapply ax_stmt_weaken_pre, ax_label; rewrite HJ.
    apply assert_exist_intro with y, assert_exist_intro with z.
    by rewrite assert_Prop_l by done. }
  eapply ax_stmt_weaken_pre; [by rewrite HJ|].
  apply ax_stmt_exist_pre; intros y'; apply ax_stmt_exist_pre; intros z'.
  apply ax_stmt_Prop_pre; try set_solver; intros Hgcd.
  eapply ax_stmt_weaken_pre.
  { by rewrite (assert_singleton_int_typed' _ _ (var 0)),
      (assert_singleton_int_typed' _ _ (var 1)), (assoc (★)%A),
      (comm _ _ (⌜ int_typed z' _ ⌝)%A), <-!(assoc (★)%A). }
  apply ax_stmt_Prop_pre; try set_solver; intros Hz'.
  apply ax_stmt_Prop_pre; try set_solver; intros Hy'.
  eapply ax_if'' with (intV{uintT} z')%B; auto.
  { apply ax_expr_frame_l'.
    rewrite (assert_singleton_l _ _ (var 1)) at 1.
    apply ax_expr_exist_pre; intros a1.
    eapply ax_expr_weaken_post';
      [by rewrite <-(assert_singleton_l_2 Γ _ (var 1) _ _ _ a1)|exec]. }
  { by eapply assert_exist_intro, assert_eval_int_unop';
      auto using assert_memext_r', assert_eval_singleton_r. }
  { apply ax_stmt_Prop_pre; try set_solver; simpl; intros.
    apply ax_local.
    set (R' v := (var 0 ↦{false,perm_full} - : uintT%BT ★ R v↑)%A).
    set (J' l := (var 0 ↦{false,perm_full} - : uintT%BT ★ (J l)↑)%A).
    set (T' n := (var 0 ↦{false,perm_full} - : uintT%BT ★ (T n)↑)%A).
    set (C' mz := (var 0 ↦{false,perm_full} - : uintT%BT ★ (C mz)↑)%A).
    rewrite !assert_lift_sep, !assert_lift_singleton; simpl.
    apply ax_comp with (
        var 0 ↦{false,perm_full} #intV{uintT} (y' `mod` z') : uintT
      ★ var 1 ↦{μ1,γ1} #intV{uintT} z' : uintT
      ★ var 2 ↦{μ2,γ2} #intV{uintT} (y' `mod` z') : uintT)%A.
    * eapply ax_do' with _ (inr (intV{uintT} (y' `mod` z')));
        [|by rewrite <-!assert_unlock_sep,
                     <-(assert_lock_singleton _ _ (var 2)), <-2!unlock_indep].
      rewrite (assert_singleton_l_ _ _ (var 0)), assert_exist_sep.
      apply ax_expr_exist_pre; intros a_tmp.
      eapply ax_expr_weaken_post';
        [by rewrite <-(assert_singleton_l_2 Γ _ (var 0) _ _ _ a_tmp)|].
      rewrite <-!(assoc (★)%A); apply ax_expr_invariant_l'.
      rewrite (right_id _ (★)%A), (assert_singleton_l _ _ (var 1)),
        (assert_exist_sep (A:=ptr _)), (assert_sep_exist (A:=ptr _)).
      apply ax_expr_exist_pre; intros a_y.
      eapply ax_expr_weaken_post';
        [by rewrite <-(assert_singleton_l_2 Γ _ (var 1) _ _ _ a_y)|].
      rewrite !(assoc (★)%A), !(comm (★)%A _ (_ ∧ _)%A).
      rewrite <-!(assoc (★)%A); apply ax_expr_invariant_l'.
      rewrite (assert_singleton_l _ _ (var 2)), !(assert_sep_exist (A:=ptr _)).
      apply ax_expr_exist_pre; intros a_z.
      eapply ax_expr_weaken_post';
        [by rewrite <-(assert_singleton_l_2 Γ _ (var 2) _ _ _ a_z)|].
      rewrite <-!(comm (★)%A _ (var 2 ⇓ _ ∧ _)%A), !(assoc (★)%A).
      apply ax_expr_invariant_r'.
      set (A' := ((var 2 ⇓ inl a_z ∧ emp) ★
        (var 1 ⇓ inl a_y ∧ emp) ★ var 0 ⇓ inl a_tmp ∧ emp)%A).
      rewrite <-!(assoc (★)%A).
      eapply ax_assign_r' with
        (%a_tmp ↦{false,perm_full} #intV{uintT} (y' `mod` z') : uintT
        ★ %a_y ↦{μ1,γ1} #intV{uintT} z' : uintT
        ★ %a_z ↦{μ2,γ2} #intV{uintT} z' : uintT)%A
        μ2 γ2 uintT%T a_z (intV{uintT} (y' `mod` z')) _; try by exec.
      { eapply ax_expr_comma' with
          (%a_tmp ↦{false,perm_full} #intV{uintT} (y' `mod` z') : uintT
          ★ %a_y ↦{μ1,γ1} #intV{uintT} y' : uintT
          ★ %a_z ↦{μ2,γ2} #intV{uintT} z' : uintT)%A
          (inr (intV{uintT} (y' `mod` z'))).
        { eapply ax_expr_weaken_post'; [by rewrite <-!assert_unlock_sep,
            <-(assert_lock_singleton _ _ (%a_tmp)), <-2!unlock_indep by done|].
          apply ax_expr_invariant_r'.
          set (A'' := ((%a_y ↦{μ1,γ1} #intV{uintT} y' : uintT%BT
            ★ %a_z ↦{μ2,γ2} #intV{uintT} z' : uintT%BT) ★ A')%A).
          eapply ax_assign_r' with _ _ perm_full
            uintT%T _ (intV{uintT} (y' `mod` z')) _.
          * exec.
          * eapply ax_binop_r'; try by exec.
            eapply assert_eval_int_arithop'; try by exec.
            + by simpl; rewrite (idemp_L _), int_promote_int.
            + by simpl; rewrite int_pre_cast_self by done.
            + simpl; rewrite !int_pre_cast_self by done.
              apply int_typed_unsigned_nonneg in Hy'.
              apply int_typed_unsigned_nonneg in Hz'.
              by rewrite Z.rem_mod_nonneg by lia.
          * cut (int_typed (y' `mod` z') uintT); [exec|].
            rewrite int_typed_spec_alt in Hz', Hy' |- *; simpl in *.
            split; [apply Z.mod_pos_bound;lia|].
            transitivity z'; [apply Z.mod_pos_bound|]; lia.
          * rewrite <-(right_id _ (★)%A) at 1.
            apply assert_sep_preserving, assert_wand_intro;
              rewrite ?(left_id _ (★)%A); eauto using assert_exist_intro.
          * done. }
        eapply ax_expr_comma' with _ (inr (intV{uintT} z')); [|exec].
        eapply ax_expr_weaken_post'; [by rewrite <-!assert_unlock_sep,
          <-(assert_lock_singleton _ _ (%a_y)), <-2!unlock_indep by done|].
        apply ax_expr_frame_l', ax_expr_invariant_r'.
        set (A'' := (%a_z ↦{μ2,γ2} #intV{uintT} z' : uintT%BT ★ A')%A).
        eapply ax_assign_r' with _ _ γ1 uintT%T _ (intV{uintT} z') _; try exec.
        * rewrite <-(right_id _ (★)%A);
          apply assert_sep_preserving, assert_wand_intro;
            rewrite ?(left_id _ (★)%A); eauto using assert_exist_intro. }
      { rewrite !(assoc (★)%A),
          (comm (★)%A _ (%a_z ↦{_,_} _ : _)%A).
        eauto using assert_sep_preserving,
          assert_wand_intro, assert_exist_intro. }
    * eapply ax_stmt_weaken_pre, ax_goto.
      apply assert_sep_preserving; eauto using assert_exist_intro.
      rewrite HJ; repeat setoid_rewrite (assert_lift_exists Γ δ).
      apply assert_exist_intro with z', assert_exist_intro with (y' `mod` z')%Z.
      rewrite !assert_lift_sep, !assert_lift_singleton, stack_indep; simpl.
      assert (Z.gcd z' (y' `mod` z') = Z.gcd y z).
      { by rewrite Z.gcd_comm, Z.gcd_mod, Z.gcd_comm by lia. }
      by rewrite assert_Prop_l by auto using Z_mod_pos, Z.gcd_mod with lia. }
  { eapply ax_stmt_weaken_pre, ax_skip; simpl.
    apply assert_Prop_intro_l; intros ->.
    by rewrite Z.gcd_0_r_nonneg in Hgcd
      by eauto using int_typed_unsigned_nonneg; subst. }
Qed.
End gcd.


(**
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
    Utf8
    Lia
    Lra

    Rdefinitions
    Rbasic_fun
    Raxioms
.

From Coquelicot Require Import
    Hierarchy
    Rbar
    Lim_seq
.

Require Import
    hierarchy_notations
    simpl_fun
    BInt_sf
    Bsf_Lsf
    CUS_Lim_seq
    topology_compl
    series
    Bi_fun
    BInt_Bif
.

Require Import
    measure
    LInt_p
    Rbar_compl
    simple_fun
    measurable_fun
    sigma_algebra
    sigma_algebra_R_Rbar_new
    subset_compl
.

Section BInt_to_LInt_p.

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

    Lemma LInt_p_minus_le :
        ∀ f g : X -> R,
        inhabited X ->
        measurable_fun_R gen f ->
        measurable_fun_R gen g ->
        (∀ x : X, 0 <= f x) ->
        (∀ x : X, 0 <= g x) ->
        is_finite (LInt_p μ f) ->
        is_finite (LInt_p μ g) ->
            Rabs (LInt_p μ f - LInt_p μ g) <= LInt_p μ (fun x => Rabs (f x - g x)).
    Proof.
        move => f g ι Hmeasf Hmeasg Hposf Hposg Hfinf Hfing.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x)))) as finH1.
        apply: Rbar_bounded_is_finite.
        apply LInt_p_ge_0 => //.
        move => x /=; apply Rabs_pos.
        2 : easy.
        apply Rbar_le_trans with (LInt_p μ (λ x : X, Rbar_plus (f x) (g x))).
        apply LInt_p_monotone.
        move => x; rewrite Rbar_finite_plus.
        setoid_rewrite <-Rabs_pos_eq at 6 7.
        2, 3 : easy.
        setoid_rewrite <-Rabs_Ropp at 3.
        unfold Rminus.
        apply Rabs_triang.
        apply Rbar_le_refl.
        rewrite LInt_p_plus => //.
        2, 3 : apply measurable_fun_R_Rbar => //.
        rewrite <-Hfinf, <-Hfing => //.

        apply Rabs_le; split.
        suff: (LInt_p μ (λ x : X, g x) <= LInt_p μ (λ x : X, Rabs (f x - g x)) + LInt_p μ (λ x : X, f x)).
        lra.
        rewrite (LInt_p_ext _ _ (fun x => Rabs (f x - g x - f x))).
        all : swap 1 2.
        move => x.
        replace (f x - g x - f x) with (- g x) by lra.
        rewrite Rabs_Ropp.
        rewrite Rabs_pos_eq => //.
        apply RIneq.Rle_trans with (LInt_p μ (λ x : X, Rabs (f x - g x) + f x)).
        suff: Rbar_le (LInt_p μ (λ x : X, Rabs (f x - g x - f x))) (LInt_p μ (λ x : X, Rabs (f x - g x) + f x)).
        all : swap 1 2.
        apply LInt_p_monotone.
        move => x /=.
        setoid_rewrite <-Rabs_pos_eq at 12.
        2 : apply Hposf.
        setoid_rewrite <-Rabs_Ropp at 3.
        unfold Rminus at 1.
        apply Rabs_triang.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x - f x)))).
        rewrite (LInt_p_ext _ _ (fun x => g x)).
        assumption.
        move => x; replace (f x - g x - f x) with (- g x) by lra.
        rewrite Rabs_Ropp Rabs_pos_eq => //.
        rewrite <-H; clear H.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x) + f x))).
        rewrite (LInt_p_ext _ _ (λ x : X, Rbar_plus (Rabs (f x - g x)) (f x))).
        rewrite LInt_p_plus.
        rewrite <-Hfinf, <-finH1 => //.
        exact ι.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        2 : move => x /=; easy.
        2 : apply measurable_fun_R_Rbar => //.
        2 : easy.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        rewrite <-H; clear H.
        simpl => //.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (Rabs (f x - g x)) (f x))).
        rewrite LInt_p_plus => //.
        rewrite <-Hfinf, <-finH1 => /=.
        apply RIneq.Rle_refl.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        apply measurable_fun_R_Rbar => //.
        by [].

        suff: (LInt_p μ (λ x : X, f x) <= LInt_p μ (λ x : X, Rabs (f x - g x)) + LInt_p μ (λ x : X, g x)) by lra.
        rewrite (LInt_p_ext _ _ (fun x => Rabs (f x - g x + g x))).
        all : swap 1 2.
        move => x.
        replace (f x - g x + g x) with (f x) by lra.
        rewrite Rabs_pos_eq => //.
        apply RIneq.Rle_trans with (LInt_p μ (λ x : X, Rabs (f x - g x) + g x)).
        suff: Rbar_le (LInt_p μ (λ x : X, Rabs (f x - g x + g x))) (LInt_p μ (λ x : X, Rabs (f x - g x) + g x)).
        all : swap 1 2.
        apply LInt_p_monotone.
        move => x /=.
        setoid_rewrite <-Rabs_pos_eq at 12.
        2 : apply Hposg.
        apply Rabs_triang.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x + g x)))).
        rewrite (LInt_p_ext _ _ (fun x => f x)).
        assumption.
        move => x; replace (f x - g x + g x) with (f x) by lra.
        rewrite Rabs_pos_eq => //.
        rewrite <-H; clear H.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x) + g x))).
        rewrite (LInt_p_ext _ _ (λ x : X, Rbar_plus (Rabs (f x - g x)) (g x))).
        rewrite LInt_p_plus.
        rewrite <-Hfing, <-finH1 => //.
        exact ι.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        2 : move => x /=; easy.
        2 : apply measurable_fun_R_Rbar => //.
        2 : easy.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        rewrite <-H; clear H.
        simpl => //.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (Rabs (f x - g x)) (g x))).
        rewrite LInt_p_plus => //.
        rewrite <-Hfing, <-finH1 => /=.
        apply RIneq.Rle_refl.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        apply measurable_fun_R_Rbar => //.
        by [].
    Qed.

    Lemma is_finite_LInt_p_Bif {f : X -> R} :
        ∀ bf : Bif μ f,
        (∀ x : X, 0 <= bf x) ->
        is_finite (LInt_p μ (λ x : X, bf x)).
    Proof.
        move => bf Pos_bf.
        rewrite (LInt_p_ext _ _ (‖ bf ‖)%fn).
        apply integrable_Bif.
        move => x; unfold fun_norm.
        unfold norm => /=.
        unfold abs => /=.
        rewrite Rabs_pos_eq => //.
    Qed.

    Definition sf_shifter (sf : simpl_fun R_NormedModule gen) :
        simpl_fun R_NormedModule gen.
    (* Definition *)
        assert (measurable gen (fun x : X => sf x ≠ 0)).
        apply (measurable_fun_sf sf (fun x : R => x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        pose M := proj1_sig (sf_bounded sf).
        exact (M ⋅ (sf_indic_aux _ _ H))%sf.
    Defined.

    Lemma pos_shifted_sf :
        ∀ sf : simpl_fun R_NormedModule gen,
            ∀ x : X, 0 <= (sf + (sf_shifter sf))%sf x.
    Proof.
        move => sf x.
        rewrite fun_sf_plus.
        unfold sf_shifter => /=.
        case: (ClassicalDescription.excluded_middle_informative
        (sf x ≠ 0)).
        move => Neq0.
        case: (sf_bounded sf) => M HM /=.
        unfold scal => /=.
        unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        unfold norm in HM; simpl in HM.
        unfold abs in HM; simpl in HM.
        apply RIneq.Rle_trans with (sf x + Rabs (sf x)).
        apply RIneq.Rle_trans with (sf x + - sf x).
        replace (sf x + - sf x) with (sf x - sf x).
        2 : unfold Rminus => //.
        rewrite RIneq.Rminus_eq_0; apply RIneq.Rle_refl.
        apply RIneq.Rplus_le_compat_l.
        apply Rcomplements.Rabs_maj2.
        apply RIneq.Rplus_le_compat_l.
        apply HM.
        case: (eq_dec (sf x) 0) => //.
        move => -> _.
        rewrite scal_zero_r.
        rewrite plus_zero_r.
        apply RIneq.Rle_refl.
    Qed.

    Lemma BInt_LInt_p_eq {f : X -> R} :
        ∀ bf : Bif μ f,
        (∀ x : X, 0 <= bf x) ->
        BInt bf = LInt_p μ (bf : X -> R).
    Proof.
        move => bf.
        case_eq bf => sf ι isf axfpw axfl1 /= Eqf axpos.
        apply lim_seq_eq => /=.
        apply is_lim_seq_epsilon.
        move => ɛ Hɛ.
        suff: (∃ N : nat,
            ∀ n : nat, N ≤ n →
            (‖ minus (BInt_sf μ (sf n + sf_shifter (sf n))%sf) (LInt_p μ (λ x : X, f x + (sf_shifter (sf n) x))) ‖) < ɛ).
        case => N HN.
        exists N => n /HN.
        rewrite BInt_sf_plus_aux.
        unfold sf_shifter.
        case: (sf_bounded (sf n)) => M HM.
        rewrite BInt_sf_scal_aux.
        rewrite BInt_sf_indic.
        simpl.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (f x) (Rbar_mult M (charac (fun x => sf n x ≠ 0) x)))).
        rewrite LInt_p_plus.
        rewrite LInt_p_scal.
        rewrite LInt_p_charac.
        assert (is_finite (μ (λ x : X, sf n x ≠ 0))).
        apply: finite_sf_preim_neq_0' => //.
        rewrite <-H => /=.
        unfold scal => /=.
        rewrite (LInt_p_ext _ _ (bf : X -> R)).
        2 : rewrite Eqf => //.
        2, 4 : exact ι.
        rewrite <-(is_finite_LInt_p_Bif).
        2 : rewrite Eqf => //.
        simpl.
        unfold minus.
        rewrite <-plus_assoc.
        rewrite opp_plus.
        setoid_rewrite plus_comm at 3.
        rewrite <-plus_assoc.
        rewrite plus_opp_l plus_zero_r.
        easy.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        move => x /=.
        unfold charac.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1,2 : move => _.
        exact RIneq.Rle_0_1.
        apply RIneq.Rle_refl.
        all : swap 1 2.
        case ι => x.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        2 : exact ι.
        all : swap 1 2.
        move => x; apply axpos.
        all : swap 3 1.
        move => x => /=.
        apply RIneq.Rmult_le_pos.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        unfold charac.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1,2 : move => _.
        exact RIneq.Rle_0_1.
        apply RIneq.Rle_refl.
        5 : apply isf.
        5 : apply: integrable_sf_indic.
        5 : apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        5 : apply measurable_gen.
        5 : apply NM_open_neq.
        5 : apply: finite_sf_preim_neq_0'.
        5 : apply isf.
        apply measurable_fun_R_Rbar.
        suff: (measurable_fun gen open f).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_ext with (fun x => bf x).
        move => x; rewrite Eqf //.
        apply: measurable_Bif; exact bf.
        apply measurable_fun_charac.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply measurable_fun_mult.
        apply measurable_fun_cte.
        apply measurable_fun_charac.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        move => x; unfold charac.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        move => Neq0 /=.
        unfold scal => /=; unfold mult => //.
        move => NNeq0 /=.
        unfold scal => /=; unfold mult => //.

        pose sigɛ := {| RIneq.pos := ɛ; RIneq.cond_pos := Hɛ |}.
        case: (axfl1 sigɛ) => _; case => N HN.
        exists N => n Hn.
        pose Hn' := (HN _ Hn); clearbody Hn'.
        rewrite Raxioms.Rplus_0_l in Hn'.
        simpl in Hn'; clear HN.
        unfold minus.
        rewrite BInt_sf_LInt_SFp.
        all : swap 1 2.
        apply integrable_sf_plus.
        apply isf.
        apply: integrable_sf_indic.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply: finite_sf_preim_neq_0'.
        apply isf.
        rewrite <-LInt_p_SFp_eq.
        2 : exact ι.
        all : swap 1 2.
        move => x /=.
        apply pos_shifted_sf.
        unfold opp.
        pose ss := sf_shifter (sf n).
        assert (ss = sf_shifter (sf n)) as Eqss by easy.
        clearbody ss.
        rewrite <-Eqss => /=.
        apply RIneq.Rle_lt_trans with (LInt_p μ (fun x => Rabs ((sf n + ss)%sf x - (f x + ss x)%R))).
        unfold norm => /=.
        unfold abs => /=.
        apply LInt_p_minus_le.
        exact ι.
        rewrite Eqss.
        suff: (measurable_fun gen open (sf n + sf_shifter (sf n))%sf).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_sf.
        apply measurable_fun_Rplus.
        suff: (measurable_fun gen open f).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_ext with (fun x => bf x).
        move => x; rewrite Eqf => //.
        apply: measurable_Bif; exact bf.
        suff: (measurable_fun gen open ss).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        rewrite Eqss.
        apply measurable_fun_sf.
        move => x; rewrite Eqss.
        apply pos_shifted_sf.
        move => x.
        apply RIneq.Rplus_le_le_0_compat.
        apply axpos.
        rewrite Eqss /=.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1, 2 : case: (sf_bounded (sf n)) => M HM.
        move => _ /=.
        unfold scal => /=; unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        move => _ /=.
        rewrite scal_zero_r; unfold zero => /=.
        apply RIneq.Rle_refl.
        replace (LInt_p μ (λ x : X, (sf n + ss)%sf x)) with
            (Finite (BInt_sf μ (sf n + ss)%sf)).
        easy.
        rewrite Finite_BInt_sf_LInt_SFp.
        rewrite <-LInt_p_SFp_eq => //.
        move => x /=.
        rewrite Eqss.
        apply pos_shifted_sf.
        apply integrable_sf_plus.
        apply isf.
        rewrite Eqss.
        apply: integrable_sf_indic.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply: finite_sf_preim_neq_0'.
        apply isf.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (f x) (ss x))).
        2 : easy.
        rewrite LInt_p_plus => //.
        rewrite (LInt_p_ext _ _ (fun x => bf x)).
        2 : move => x; rewrite Eqf => //.
        pose H := (integrable_Bif bf).
        rewrite <-is_finite_LInt_p_Bif.
        2 : rewrite Eqf => //.
        assert (is_finite (LInt_p μ (λ x : X, ss x))).
        replace (LInt_p μ (λ x : X, (ss)%sf x)) with
            (Finite (BInt_sf μ (ss)%sf)).
        easy.
        rewrite Finite_BInt_sf_LInt_SFp.
        rewrite <-LInt_p_SFp_eq => //.
        move => x.
        rewrite Eqss /=.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1, 2 : case: (sf_bounded (sf n)) => M HM.
        move => _ /=.
        unfold scal => /=; unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        move => _ /=.
        rewrite scal_zero_r; unfold zero => /=.
        apply RIneq.Rle_refl.
        rewrite Eqss.
        apply: integrable_sf_indic.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply: finite_sf_preim_neq_0'.
        apply isf.
        rewrite <-H0.
        apply Rbar_finite_plus.
        apply measurable_fun_R_Rbar.
        suff: (measurable_fun gen open f).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_ext with (fun x => bf x).
        move => x; rewrite Eqf //.
        apply: measurable_Bif; exact bf.
        rewrite Eqss => x /=.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1, 2 : case: (sf_bounded (sf n)) => M HM.
        move => _ /=.
        unfold scal => /=; unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        move => _ /=.
        rewrite scal_zero_r; unfold zero => /=.
        apply RIneq.Rle_refl.
        apply measurable_fun_R_Rbar.
        suff: (measurable_fun gen open (λ x, ss x)).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        rewrite Eqss.
        apply measurable_fun_sf.

        rewrite (LInt_p_ext _ _ (λ x : X, (‖ f - sf n ‖)%fn x)).
        assert (is_finite (LInt_p μ (λ x : X, (‖ f - sf n ‖)%fn x))).
        apply Rbar_bounded_is_finite with 0 ɛ.
        apply LInt_p_ge_0 => //.
        move => x; unfold fun_norm; apply norm_ge_0.
        apply Rbar_lt_le => //.
        1, 2 : easy.
        rewrite <-H in Hn'.
        simpl in Hn' => //.
        move => x; unfold fun_norm, norm => /=.
        unfold abs => /=.
        unfold fun_plus.
        rewrite fun_sf_plus.
        unfold fun_scal.
        rewrite scal_opp_one.
        unfold opp => /=.
        unfold plus => /=.
        unfold Rminus.
        rewrite Rplus_assoc.
        setoid_rewrite Rplus_comm at 2.
        rewrite <-Rplus_assoc.
        rewrite RIneq.Ropp_plus_distr.
        do 2 rewrite Rplus_assoc.
        rewrite RIneq.Rplus_opp_l.
        rewrite RIneq.Rplus_0_r.
        rewrite <-Rabs_Ropp.
        rewrite RIneq.Ropp_plus_distr.
        rewrite RIneq.Ropp_involutive.
        congr Rabs.
        rewrite Rplus_comm => //.
    Qed.

End BInt_to_LInt_p.


(** * Writer *)

(** Output events. *)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
     List.
Import ListNotations.

From ExtLib Require Import
     Structures.Functor
     Structures.Monad
     Structures.Monoid.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.MonadState
     Indexed.Function
     Indexed.Sum
     Core.ITreeDefinition
     Core.Subevent
     Interp.Interp
     Interp.Handler
     Events.State.

Import Basics.Basics.Monads.
(* end hide *)

(** Event to output values of type [W]. *)
Variant writerE (W : Type) : Type -> Type :=
| Tell : W -> writerE W unit.

(** Output action. *)
Definition tell {W E} `{writerE W -< E} : W -> itree E unit :=
  fun w => trigger (Tell w).

(** One interpretation is to accumulate outputs in a list. *)

(** Note that this handler appends new outputs to the front of the list. *)
Definition handle_writer_list {W E}
  : writerE W ~> stateT (list W) (itree E)
  := fun _ e s =>
       match e with
       | Tell w => Ret (w :: s, tt)
       end.

Definition run_writer_list_state {W E}
  : itree (writerE W +' E) ~> stateT (list W) (itree E)
  := interp_state (case_ handle_writer_list pure_state).

Arguments run_writer_list_state {W E} [T].

(** Returns the outputs in order: the first output at the head, the last
    output and the end of the list. *)
Definition run_writer_list {W E}
  : itree (writerE W +' E) ~> writerT (list W) (itree E)
  := fun _ t =>
       ITree.map (fun wsx => (rev' (fst wsx), snd wsx))
                 (run_writer_list_state t []).

Arguments run_writer_list {W E} [T].

(** When [W] is a monoid, we can also use that to append the outputs together. *)

Definition handle_writer {W E} (Monoid_W : Monoid W)
  : writerE W ~> stateT W (itree E)
  := fun _ e s =>
       match e with
       | Tell w => Ret (monoid_plus Monoid_W s w, tt)
       end.

Definition run_writer {W E} (Monoid_W : Monoid W)
  : itree (writerE W +' E) ~> writerT W (itree E)
  := fun _ t =>
       interp_state (case_ (handle_writer Monoid_W) pure_state) t
                    (monoid_unit Monoid_W).

Arguments run_writer {W E} Monoid_W [T].


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

- Frederic Blanqui, 2009-05-06

list of reducts of a term and proof that rewriting is finitely branching
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil ATrs RelUtil ListUtil VecUtil AMatching
     NatUtil.

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig). Notation terms := (vector term).
  Notation rule := (rule Sig). Notation rules := (list rule).

(***********************************************************************)
(** top reducts *)

  Definition top_reduct (t : term) lr :=
    match matches (lhs lr) t with
      | Some s => Some (sub s (rhs lr))
      | None => None
    end.

  Lemma top_reduct_correct : forall R lr t u,
    In lr R -> top_reduct t lr = Some u -> hd_red R t u.

  Proof.
    intros R0 lr t u hlr. unfold top_reduct. destruct lr as [l r]. simpl.
    case_eq (matches l t); intros t0 H.
    intro H0. ded (matches_correct H). subst. inversion H0.
    apply hd_red_rule. hyp. discr.
  Qed.

  Definition top_reducts R t := filter_opt (top_reduct t) R.

  Lemma top_reducts_correct : forall t u R,
    In u (top_reducts R t) -> hd_red R t u.

  Proof.
    induction R; simpl. contr.
    assert (h : List.incl R (a::R)). unfold List.incl. simpl. auto.
    case_eq (top_reduct t a); intros t0 H.
    intro H0. simpl in H0. split_all. subst.
    eapply top_reduct_correct with (lr := a). simpl. auto. hyp.
    eapply incl_elim. apply hd_red_incl with (x := R). hyp. tauto.
    eapply incl_elim. apply hd_red_incl with (x := R). hyp. tauto.
  Qed.

  Arguments top_reducts_correct [t u R] _.

  Lemma top_reducts_correct_red : forall t u R,
    In u (top_reducts R t) -> red R t u.

  Proof.
    intros. ded (top_reducts_correct H).
    eapply incl_elim. apply hd_red_incl_red. hyp.
  Qed.

  Lemma top_reducts_complete : forall t u R,
    rules_preserve_vars R -> hd_red R t u -> In u (top_reducts R t).

  Proof.
    induction R; intros; redtac. hyp. simpl in lr.
    assert (h0 : rules_preserve_vars R). eapply rules_preserve_vars_incl.
    2: apply H. apply incl_tl. refl. split_all.
    (* In (mkRule l r) R *)
    2:{ simpl. assert (h1 : hd_red R t u). subst. apply hd_red_rule. hyp.
    case (top_reduct t a). right. apply IHR; hyp. apply IHR; hyp. }
    (* a = mkRule l r *)
    subst a. simpl. unfold top_reduct. simpl.
    case_eq (matches l t).
    intros t0 H0. ded (matches_correct H0). left. subst u. apply sub_eq. intros.
    eapply subeq_inversion. rewrite xl in H1. apply H1.
    unfold rules_preserve_vars in H. unfold List.incl in H. eapply H. simpl.
    auto. hyp.
    intro H0. symmetry in xl. ded (matches_complete xl). congruence.
  Qed.

(***********************************************************************)
(** list of reducts of a term *)

  Variable R : rules.

  Lemma reducts_aux1 : forall k n, S k <= n -> k <= n.

  Proof. lia. Qed.

  Lemma reducts_aux2 : forall k n, S k <= n -> n - S k < n.

  Proof. lia. Qed.

  Fixpoint reducts t :=
    match t with
      | Var _ => top_reducts R t
      | Fun f ts =>
        let fix reducts_vec k (us : terms k) : k <= arity f -> list term :=
          match us in vector _ k return k <= arity f -> list term with
            | Vnil => fun _ => nil
            | Vcons u1 us' => fun h =>
              map (fun x => Fun f (Vreplace ts (reducts_aux2 h) x)) (reducts u1)
              ++ reducts_vec _ us' (reducts_aux1 h)
          end
          in top_reducts R t ++ reducts_vec (arity f) ts (le_refl (arity f))
    end.

  Fixpoint reducts_vec f ts k (us : terms k) : k <= arity f -> list term :=
    match us in vector _ k return k <= arity f -> list term with
      | Vnil => fun _ => nil
      | Vcons u1 us' => fun h =>
        map (fun x => Fun f (Vreplace ts (reducts_aux2 h) x)) (reducts u1)
        ++ reducts_vec f ts us' (reducts_aux1 h)
    end.

  Lemma fix_reducts_vec : forall f ts k us h,
    (fix reducts_vec (k : nat) (us : terms k) : k <= arity f -> list term :=
      match us in (vector _ k0) return (k0 <= arity f -> list term) with
        | Vnil => fun _ => nil
        | Vcons u1 us' => fun h =>
          map (fun x => Fun f (Vreplace ts (reducts_aux2 h) x)) (reducts u1)
          ++ reducts_vec _ us' (reducts_aux1 h)
      end) k us h = reducts_vec f ts us h.

  Proof.
    induction us; simpl; intros. refl. apply app_eq. refl. apply IHus.
  Qed.

  Lemma reducts_fun : forall f ts, reducts (Fun f ts)
    = top_reducts R (Fun f ts) ++ reducts_vec f ts ts (le_refl (arity f)).

  Proof. intros. simpl. rewrite <- fix_reducts_vec. refl. Qed.

(***********************************************************************)
(** properties *)

  Lemma reducts_vec_pi : forall f ts k (us : terms k) h h',
    reducts_vec f ts us h = reducts_vec f ts us h'.

  Proof. intros. assert (h=h'). apply le_unique. subst h'. refl. Qed.

  Lemma reducts_vec_cast : forall f ts k (us : terms k) h k' (e : k = k') h',
    reducts_vec f ts (Vcast us e) h' = reducts_vec f ts us h.

  Proof.
    induction us; intros; destruct k'; try discr. rewrite Vcast_refl. refl.
    rewrite Vcast_cons. simpl. inversion e. subst k'.
    apply app_eq. apply map_eq. intros. apply args_eq. apply Vreplace_pi.
    lia. apply IHus.
  Qed.

  (*Arguments reducts_vec_cast [f ts k us] _ [k' e h'].*)

  Lemma In_reducts_vec_elim_aux : forall v' f ts k (us : terms k),
    (forall i (p : i < k), exists r : arity f - k + i < arity f,
      Vnth us p = Vnth ts r) -> forall h, In v' (reducts_vec f ts us h) ->
    exists i, exists p : i < arity f, exists u',
      In u' (reducts (Vnth ts p)) /\ v' = Fun f (Vreplace ts p u').

  Proof.
    induction us.
    (* Vnil *)
    contr.
    (* Vcons *)
    intros E g H. simpl in H. rewrite in_app in H. split_all.
    (* case 1 *)
    ded (in_map_elim H). decomp H0. destruct (E 0 (lt_O_Sn n)). simpl in H0.
    ex (arity f - S n + 0) x0 x. rewrite <- H0. split_all.
    rewrite H3. apply args_eq. apply Vreplace_pi. lia.
    (* case 2 *)
    assert (E' : forall (i : nat) (p : i < n),
      exists r : arity f - n + i < arity f, Vnth us p = Vnth ts r). intros.
    assert (p' : S i < S n). lia. destruct (E (S i) p'). simpl in H.
    assert (lt_S_n p' = p). apply lt_unique. simpl in H0. rewrite H1 in H0.
    rewrite H0.
    assert (r : arity f - n + i < arity f). lia. exists r. apply Vnth_eq.
    lia.
    assert (h' : n <= arity f). lia.
    rewrite reducts_vec_pi with (h':=h') in H.
    apply IHus with (h:=h'); hyp.
  Qed.

  Arguments In_reducts_vec_elim_aux [v' f ts k us] _ [h] _.

  Lemma In_reducts_vec_elim : forall v' f ts,
    In v' (reducts_vec f ts ts (le_refl (arity f))) ->
    exists i, exists p : i < arity f, exists u',
      In u' (reducts (Vnth ts p)) /\ v' = Fun f (Vreplace ts p u').

  Proof.
    intros. apply In_reducts_vec_elim_aux
    with (k := arity f) (us := ts) (h := le_refl (arity f)).
    intros. assert (r : arity f - arity f + i < arity f). lia. exists r.
    apply Vnth_eq. lia. hyp.
  Qed.

  Arguments In_reducts_vec_elim [v' f ts] _.

  Lemma In_reducts_vec_intro_aux : forall f ts k (us : terms k)
    (h : k <= arity f) t i (p : i < k) (q : arity f - k + i < arity f),
    In t (reducts (Vnth us p)) ->
    In (Fun f (Vreplace ts q t)) (reducts_vec f ts us h).

  Proof.
    induction us.
    (* Vnil *)
    intros. lia.
    (* Vcons *)
    intros g t. simpl.
    set (F := fun x : term => Fun f (Vreplace ts (reducts_aux2 g) x)).
    destruct i; intros p q; rewrite in_app.
    (* i = 0 *)
    left. assert (e : arity f - S n + 0 = arity f - S n). lia.
    rewrite (Vreplace_pi ts q (reducts_aux2 g) t e).
    apply in_map with (f:=F). hyp.
    (* i > 0 *)
    right. assert (q' : arity f - n + i < arity f). lia.
    assert (Vreplace ts q t = Vreplace ts q' t). apply Vreplace_pi. lia.
    rewrite H0. apply IHus with (p := lt_S_n p). hyp.
  Qed.

  Arguments In_reducts_vec_intro_aux _ _ [k us] _ _ [i p] _ _.

  Lemma In_reducts_vec_intro : forall f ts t i (p : i < arity f),
    In t (reducts (Vnth ts p)) ->
    In (Fun f (Vreplace ts p t)) (reducts_vec f ts ts (le_refl (arity f))).

  Proof.
    intros. assert (q : arity f - arity f + i < arity f). lia.
    assert (Vreplace ts p t = Vreplace ts q t). apply Vreplace_pi. lia.
    rewrite H0. apply In_reducts_vec_intro_aux with (p := p). hyp.
  Qed.

(***********************************************************************)
(** alternative definition (Pierre-Yves Strub) *)

  Fixpoint reducts2 t :=
    match t with
      | Var _ => top_reducts R t
      | Fun f ts =>
        let fix reducts2_vec k (us : terms k) : list (terms k) :=
          match us with
            | Vnil => nil
            | Vcons u1 us' => map (fun x => Vcons x us') (reducts2 u1)
              ++ map (fun x => Vcons u1 x) (reducts2_vec _ us')
          end
          in top_reducts R t ++ map (Fun f) (reducts2_vec (arity f) ts)
    end.

  Fixpoint reducts2_vec k (us : terms k) : list (terms k) :=
    match us with
      | Vnil => nil
      | Vcons u1 us' => map (fun x => Vcons x us') (reducts2 u1)
        ++ map (fun x => Vcons u1 x) (reducts2_vec us')
    end.

  Lemma reducts2_fun : forall f ts, reducts2 (Fun f ts)
    = top_reducts R (Fun f ts) ++ map (Fun f) (reducts2_vec ts).

  Proof. auto. Qed.

  Lemma In_reducts2_vec_elim : forall n (vs ts : terms n),
    In vs (reducts2_vec ts) -> exists i, exists p : i < n, exists u,
      In u (reducts2 (Vnth ts p)) /\ vs = Vreplace ts p u.

  Proof.
    induction ts; intros.
    (* Vnil *)
    contr.
    (* Vcons *)
    simpl in H. rewrite in_app in H.
    split_all; ded (in_map_elim H); clear H; decomp H0.
    (* case 1 *)
    set (p := lt_O_Sn n). ex 0 p x. simpl. auto.
    (* case 2 *)
    ded (IHts x H1); clear IHts. decomp H. assert (p : S x0<S n). lia.
    ex (S x0) p x2. simpl. assert (lt_S_n p = x1). apply lt_unique.
    rewrite H. subst x. auto.
  Qed.

  Arguments In_reducts2_vec_elim [n vs ts] _.

  Lemma In_reducts2_vec_intro : forall n (ts : terms n) t i (p : i < n),
    In t (reducts2 (Vnth ts p)) -> In (Vreplace ts p t) (reducts2_vec ts).

  Proof.
    induction ts.
    (* Vnil *)
    intros. lia.
    (* Vcons *)
    destruct i; simpl; intro; rewrite in_app.
    left. apply in_map with (f := fun x => Vcons x ts). hyp.
    right. apply in_map with (f := fun x => Vcons h x). apply IHts. hyp.
  Qed.

(***********************************************************************)
(** correctness *)

  Lemma reducts_correct : forall t u, In u (reducts t) -> red R t u.

  Proof.
    intro t. pattern t; apply term_ind_forall; clear t.
    (* Var *)
    intros. apply top_reducts_correct_red. hyp.
    (* Fun *)
    intros f ts IH u. rewrite reducts_fun, in_app. split_all.
    apply hd_red_incl_red. apply top_reducts_correct. hyp.
    rename H into h. ded (In_reducts_vec_elim h). decomp H.
    ded (Vforall_nth x0 IH _ H1). redtac. unfold red. ex l r.
    assert (h1 : 0+x<=arity f). lia. set (v1 := Vsub ts h1).
    assert (h2 : S x+(arity f-S x)<=arity f). lia. set (v2 := Vsub ts h2).
    assert (e : x+S(arity f-S x)=arity f). lia.
    exists (Cont f e v1 c v2). exists s. split_all. simpl. apply args_eq.
    rewrite <- xl. unfold v2. rewrite Vcons_nth. unfold v1.
    apply Veq_app_cons_aux.
    simpl. rewrite H2. apply args_eq. apply Veq_nth; intros.
    rewrite Vnth_cast, Vnth_app. destruct (le_gt_dec x i).
    (* 1) x <= i *)
    destruct (eq_nat_dec x i).
    (* a) x = i *)
    set (q := Vnth_app_aux (S (arity f - S x)) (Vnth_cast_aux e ip) l0).
    gen q. assert (i - x = 0). subst; clear; lia. rewrite H. intro. simpl.
    trans (Vnth (Vreplace ts x0 x1) x0). apply Vnth_eq. auto.
    rewrite Vnth_replace. hyp.
    (* b) x <> i *)
    rewrite Vnth_replace_neq. 2: hyp.
    rewrite (Veq_app_cons ts x0), Vnth_cast, Vnth_app. destruct (le_gt_dec x i).
    2: lia.
    rewrite !Vnth_cons. destruct (lt_ge_dec 0 (i-x)). unfold v2.
    rewrite !Vnth_sub. apply Vnth_eq. refl. lia.
    (* 2) x > i *)
    rewrite Vnth_replace_neq. 2: lia.
    rewrite (Veq_app_cons ts x0), Vnth_cast, Vnth_app. destruct (le_gt_dec x i).
    lia.
    assert (g0 = g). apply lt_unique. subst g0.
    assert (Vsub ts (Veq_app_cons_aux1 x0) = v1). unfold v1.
    f_equal. apply le_unique. rewrite H. refl.
  Qed.

(***********************************************************************)
(** completeness *)

  Lemma reducts_complete : rules_preserve_vars R ->
    forall t u, red R t u -> In u (reducts t).

  Proof.
    intros H t; pattern t; apply term_ind_forall; clear t; intros.
    (* Var *)
    ded (red_case H0). split_all.
    simpl. apply top_reducts_complete; hyp.
    decomp H2. discr.
    (* Fun *)
    rewrite reducts_fun, in_app. ded (red_case H1). split_all.
    left. apply top_reducts_complete; hyp.
    right. Funeqtac. subst x0. ded (Vforall_nth x2 H0). subst u.
    apply In_reducts_vec_intro. apply H2. hyp.
  Qed.

(***********************************************************************)
(** rewriting is finitely branching *)

  Lemma fin_branch : rules_preserve_vars R -> finitely_branching (red R).

  Proof.
    unfold finitely_branching. intros. exists (reducts x). split_all.
    apply reducts_complete; hyp. apply reducts_correct. hyp.
  Qed.

End S.


(** * Some useful tools to manipulate lists of lists instead of multisets of multisets (and so to deal with the exchange rules) *)
Require Import Rpos.
Require Import RL.hmr.term.
Require Import RL.hmr.hseq.

Require Import CMorphisms.
Require Import Lra.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Definition Allperm := (Forall2_inf (Permutation_Type (A:=Rpos * term))).

Lemma decomp_Permutation_Type_2 A : forall l l' (x y : A),
    Permutation_Type (x :: y :: l) l' ->
    {' (l1,l2,l3) : _ & {l' = l1 ++ x :: l2 ++ y :: l3} +
                        {l' = l1 ++ y :: l2 ++ x :: l3}}.
Proof.
  intros l l' x y Hperm.
  destruct (in_inf_split x l') as [[la lb] Heq].
  { apply Permutation_Type_in_inf with (x :: y :: l); [ apply Hperm | ].
    left; reflexivity. }
  case (in_inf_app_or la lb y).
  { apply Permutation_Type_in_inf with (y :: l) ; [ | left; reflexivity].
    apply Permutation_Type_cons_inv with x.
    rewrite Heq in Hperm; Permutation_Type_solve. }
  - intros Hin.
    apply in_inf_split in Hin as [[l1 l2] Heq' ].
    split with (l1 , l2 , lb).
    right; subst.
    rewrite <- ? app_assoc; reflexivity.
  - intros Hin.
    apply in_inf_split in Hin as [[l1 l2] Heq' ].
    split with (la , l1 , l2).
    left; subst; reflexivity.
Qed.

Lemma decomp_M_case : forall T1 T2 r D A,
    Permutation_Type (T1 ++ T2) (vec r A ++ D) ->
    {' (D1, D2, r1, r2) : _ &
                          prod (Permutation_Type r (r1 ++ r2))
                               ((Permutation_Type D (D1 ++ D2)) *
                                (Permutation_Type T1 (vec r1 A ++ D1)) *
                                (Permutation_Type T2 (vec r2 A ++ D2)))}.
Proof.
  intros T1 T2 r D A Hperm.
  revert T1 T2 D Hperm; induction r; intros T1 T2 D Hperm.
  - simpl in Hperm.
    split with (T1 , T2, nil, nil).
    simpl; repeat split; try Permutation_Type_solve.
  - simpl in Hperm.
    case (in_inf_app_or T1 T2 (a , A)).
    + apply Permutation_Type_in_inf with ((a, A) :: vec r A ++ D); try Permutation_Type_solve.
      left; reflexivity.
    + intros Hin.
      apply in_inf_split in Hin as [[l1 l2] Heq].
      destruct (IHr (l1 ++ l2) T2 D) as [[[[D1 D2] r1'] r2] [H1' [[H2 H3] H4]]].
      * apply Permutation_Type_cons_inv with (a, A).
        rewrite Heq in Hperm; Permutation_Type_solve.
      * split with (D1, D2, (a :: r1'), r2).
        rewrite Heq; simpl; repeat split; try Permutation_Type_solve.
    + intros Hin.
      apply in_inf_split in Hin as [[l1 l2] Heq].
      destruct (IHr T1 (l1 ++ l2) D) as [[[[D1 D2] r1'] r2] [H1' [[H2 H3] H4]]].
      * apply Permutation_Type_cons_inv with (a, A).
        rewrite Heq in Hperm; Permutation_Type_solve.
      * split with (D1, D2, r1', (a :: r2)).
        rewrite Heq; simpl; repeat split; try Permutation_Type_solve.
Qed.

Lemma decomp_M_case_2 : forall T1 T2 r s D A B,
    Permutation_Type (T1 ++ T2) (vec r A ++ vec s B ++ D) ->
    {' (D1, D2, r1, r2, s1, s2) : _ &
                          prod (Permutation_Type r (r1 ++ r2))
                               ((Permutation_Type s (s1 ++ s2)) *
                                (Permutation_Type D (D1 ++ D2)) *
                                (Permutation_Type T1 (vec r1 A ++ vec s1 B ++ D1)) *
                                (Permutation_Type T2 (vec r2 A ++ vec s2 B ++ D2)))}.
Proof.
  intros T1 T2 r s D A B Hperm.
  apply decomp_M_case in Hperm as [[[[D1 D2] r1] r2] [H1 [[H2 H3] H4]]].
  symmetry in H2.
  apply decomp_M_case in H2 as [[[[D1' D2'] s1] s2] [H1' [[H2' H3'] H4']]].
  split with (D1', D2', r1,r2,s1,s2).
  repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq_2 : forall T D r s t A B C,
    A <> B ->
    A <> C ->
    Permutation_Type (vec s B ++ vec t C ++ T) (vec r A ++ D) ->
    {' (Ta, Tb, Da, Db) : _ &
                          prod (Permutation_Type T (Ta ++ Tb))
                               ((Permutation_Type D (Da ++ Db)) *
                                (Permutation_Type (vec s B ++ vec t C) Da) *
                                (Permutation_Type (vec r A) Ta) *
                                (Permutation_Type Tb Db)) }.
Proof.
  intros T D r s t A B C Hnc Hnv Hperm.
  revert D r Hperm; induction s; [ induction t | ]; intros D r Hperm.
  - split with (vec r A , D, nil, D).
    repeat split; try assumption; try reflexivity.
  - simpl in *.
    assert (In_inf (a, C) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , C)).
      + apply Permutation_Type_in_inf with ((a, C) :: vec t C ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hnv.
        induction r; inversion i.
        * inversion H.
          apply Hnv; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHt D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, C).
      etransitivity; [ apply Hperm | ].
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, C):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
  - simpl in *.
    assert (In_inf (a, B) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , B)).
      + apply Permutation_Type_in_inf with ((a, B) :: vec s (B) ++ vec t C ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hnc.
        induction r; inversion i.
        * inversion H.
          apply Hnc; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHs D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, B).
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, B):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq : forall T D r s A B,
    A <> B ->
    Permutation_Type (vec s B ++ T) (vec r A ++ D) ->
    {' (Ta, Tb, Da, Db) : _ &
                          prod (Permutation_Type T (Ta ++ Tb))
                               ((Permutation_Type D (Da ++ Db)) *
                                (Permutation_Type (vec s B) Da) *
                                (Permutation_Type (vec r A) Ta) *
                                (Permutation_Type Tb Db)) }.
Proof.
  intros T D r s A B Hneq Hperm.
  revert D r Hperm; induction s; intros D r Hperm.
  - split with (vec r A , D, nil, D).
    repeat split; try assumption; try reflexivity.
  - simpl in *.
    assert (In_inf (a, B) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , B)).
      + apply Permutation_Type_in_inf with ((a, B) :: vec s B ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hneq.
        induction r; inversion i.
        * inversion H.
          apply Hneq; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHs D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, B).
      etransitivity; [ apply Hperm | ].
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, B):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_eq : forall T D r s A,
    Permutation_Type (vec s A ++ T) (vec r A ++ D) ->
    {' (a , b , c , T', D') : _ &
                     prod (Permutation_Type r  (a ++ b))
                          ((Permutation_Type s  (b ++ c)) *
                           (Permutation_Type T (vec a A ++ T')) *
                           (Permutation_Type D (vec c A ++ D')) *
                           (Permutation_Type T' D')) }.
Proof.
  intros T D r s A Hperm.
  revert D r Hperm; induction s; intros D r Hperm.
  + split with (r, nil, nil, D , D).
    repeat split; try Permutation_Type_solve.
  + simpl in Hperm.
    case (in_inf_app_or (vec r A) D (a , A)).
    * apply Permutation_Type_in_inf with ((a, A) :: vec s A ++ T); [apply Hperm | ].
      left; reflexivity.
    * intro Hin.
      assert { r' & Permutation_Type r (a :: r')}.
      { clear - Hin.
        induction r.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with r; simpl; reflexivity.
          + specialize (IHr Hin) as [r' Hperm].
            split with (a0 :: r').
            Permutation_Type_solve. }
      destruct X as [r' Hperm'].
      destruct (IHs D r') as [ [[[[a1 b1] c1] T'] D'] [H1 [[[H2 H3] H4] H5]]].
      { apply Permutation_Type_cons_inv with (a, A).
        transitivity (vec r A ++ D); try Permutation_Type_solve.
        change ((a, A) :: vec r' A ++ D) with (vec (a :: r') A ++ D).
        apply Permutation_Type_app; try reflexivity.
        apply vec_perm; apply Hperm'. }
      split with (a1 , a :: b1, c1, T' , D').
      repeat split; try Permutation_Type_solve.
    * intro Hin.
      destruct (Add_inf_inv _ _ Hin) as [D' Hadd].
      apply Permutation_Type_Add_inf in Hadd.
      destruct (IHs D' r) as [ [[[[a1 b1] c1] T'] D''] [H1 [[[H2 H3] H4] H5]]].
      { apply Permutation_Type_cons_inv with (a, A).
        Permutation_Type_solve. }
      split with (a1, b1, a :: c1 , T', D'').
      repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_eq_2 : forall T D r s r' s' A B,
    A <> B ->
    Permutation_Type (vec s' B ++ vec r' A ++ T) (vec s B ++ vec r A ++ D) ->
    {' (a1 , b1 , c1, a2 , b2, c2, T', D') : _ &
                     prod (Permutation_Type r  (a1 ++ b1))
                          ((Permutation_Type r'  (b1 ++ c1)) *
                           (Permutation_Type s  (a2 ++ b2)) *
                           (Permutation_Type s'  (b2 ++ c2)) *
                           (Permutation_Type T (vec a2 B ++ vec a1 A ++ T')) *
                           (Permutation_Type D (vec c2 B ++ vec c1 A ++ D')) *
                           (Permutation_Type T' D')) }.
Proof.
  intros T D r s r' s' A B Hneq Hperm.
  revert s r' r T D A B Hneq Hperm.
  induction s'; [ intros s ; induction s ; [ intros r'; induction r'; [ intros r; induction r | ] | ] | ].
  - intros T D A B Hneq Hperm.
    split with (nil, nil,nil,nil,nil,nil , T , D).
    repeat split; try Permutation_Type_solve.
  - intros T D A B Hneq Hperm.
    simpl in *.
    destruct (in_inf_split (a , A) T) as [[T1 T2] HeqT].
    { apply Permutation_Type_in_inf with ((a , A) :: vec r A ++ D); try Permutation_Type_solve.
      left; reflexivity. }
    subst.
    destruct (IHr (T1 ++ T2) D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
    { apply Permutation_Type_cons_inv with (a , A).
      Permutation_Type_solve. }
    split with ((a :: a1), b1,c1,a2,b2,c2, T' , D').
    repeat split; try Permutation_Type_solve.
  - intros r T D A B Hneq Hperm; simpl in *.
    case (in_inf_app_or (vec r A) D (a , A)).
    { apply Permutation_Type_in_inf with ((a , A) :: vec r' A ++ T); try Permutation_Type_solve.
      left; reflexivity. }
    + intros Hin.
      assert { r' & Permutation_Type r (a :: r')}.
      { clear - Hin.
        induction r.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with r; simpl; reflexivity.
          + specialize (IHr Hin) as [r' Hperm].
            split with (a0 :: r').
            Permutation_Type_solve. }
      destruct X as [vr Hperm'].
      destruct (IHr' vr T D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a , A).
        change ((a , A) :: vec vr A ++ D) with (vec (a :: vr) A ++ D).
        etransitivity ; [ apply Hperm | ].
        apply Permutation_Type_app; [ apply vec_perm | ]; Permutation_Type_solve. }
      split with (a1, a :: b1, c1, a2, b2, c2, T', D').
      repeat split; simpl; try Permutation_Type_solve.
    + intros Hin.
      apply in_inf_split in Hin as [[D1 D2] HeqD]; subst.
      destruct (IHr' r T (D1 ++ D2) A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a,  A).
        Permutation_Type_solve. }
      split with (a1, b1, a :: c1 , a2, b2, c2, T', D').
      simpl; repeat split; try Permutation_Type_solve.
  - intros r' r T D A B Hneq Hperm; simpl in *.
    assert (In_inf (a , B) T).
    { case (in_inf_app_or (vec r' A) T (a , B)); try (intro H; assumption).
      { apply Permutation_Type_in_inf with ((a, B) :: vec s B ++ vec r A ++ D); try Permutation_Type_solve.
        left; reflexivity. }
      intro H; exfalso; clear - H Hneq.
      induction r'; simpl in H; inversion H.
      + inversion H0; subst; now apply Hneq.
      + apply IHr'; try assumption. }
    apply in_inf_split in X as [[T1 T2] Heq]; subst.
    destruct (IHs r' r (T1 ++ T2) D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
    { apply Permutation_Type_cons_inv with (a , B).
      Permutation_Type_solve. }
    split with (a1, b1,c1,a :: a2,b2,c2, T' , D').
    repeat split; try Permutation_Type_solve.
  - intros s r' r T D A B Hneq Hperm; simpl in *.
    case (in_inf_app_or (vec s B) (vec r A ++ D) (a , B)).
    { apply Permutation_Type_in_inf with ((a, B) :: vec s' B ++ vec r' A ++ T); try Permutation_Type_solve.
      left; reflexivity. }
    + intros Hin.
      assert { s' & Permutation_Type s (a :: s')}.
      { clear - Hin.
        induction s.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with s; simpl; reflexivity.
          + specialize (IHs Hin) as [s' Hperm].
            split with (a0 :: s').
            Permutation_Type_solve. }
      destruct X as [vs Hperm'].
      destruct (IHs' vs r' r T D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a , B).
        change ((a , B) :: vec vs B ++ vec r A ++  D) with (vec (a :: vs) B ++ vec r A ++ D).
        etransitivity ; [ apply Hperm | ].
        apply Permutation_Type_app; [ apply vec_perm | ]; Permutation_Type_solve. }
      split with (a1, b1, c1, a2, a::b2, c2, T', D').
      repeat split; simpl; try Permutation_Type_solve.
    + intros H.
      assert (In_inf (a , B) D) as Hin; [ | clear H].
      { case (in_inf_app_or (vec r A) D (a , B)); [ apply H | | ]; try (intros H0; assumption).
        intro H0; exfalso; clear - H0 Hneq.
        induction r; simpl in H0; inversion H0.
        - inversion H; subst; now apply Hneq.
        - apply IHr; try assumption. }
      apply in_inf_split in Hin as [[D1 D2] HeqD]; subst.
      destruct (IHs' s r' r T (D1 ++ D2) A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a,  B).
        Permutation_Type_solve. }
      split with (a1, b1, c1 , a2, b2, a :: c2, T', D').
      simpl; repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq_2_2 : forall T1 T2 r s r' s' A B C D,
    A <> C ->
    A <> D ->
    B <> C ->
    B <> D ->
    Permutation_Type (vec s A ++ vec r B ++ T1) (vec s' C ++ vec r' D ++ T2) ->
    {' (T', D') : _ &
                          prod (Permutation_Type T1 (vec s' C ++ vec r' D ++ T'))
                               ((Permutation_Type T2 (vec s A ++ vec r B ++ D')) *
                                (Permutation_Type T' D'))}.
Proof.
  intros T1 T2 r s r' s'.
  revert s r' r T1 T2.
  induction s'; [ intros s ; induction s ; [ intros r' ; induction r' ; [ intros r; induction r | ] | ] | ].
  - intros T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    split with (T1, T2).
    simpl in *; repeat split; Permutation_Type_solve.
  - intros T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , B) T2) as [[D1 D2] Heq].
    { apply Permutation_Type_in_inf with ((a, B) :: vec r B ++ T1); try Permutation_Type_solve.
      left; reflexivity. }
    subst.
    destruct (IHr T1 (D1 ++ D2) A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , B).
      Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
  - intros r T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , D) T1) as [[T1' T2'] Heq].
    { case (in_inf_app_or (vec r B) T1 (a , D)) ; [ apply Permutation_Type_in_inf with ((a, D) :: vec r' D ++ T2); [ Permutation_Type_solve | left; reflexivity ] | | auto ].
      intros H; clear - H Hneq4.
      exfalso.
      induction r; simpl in H; inversion H.
      - inversion H0.
        apply Hneq4; apply H3.
      - apply IHr; apply X. }
    subst.
    destruct (IHr' r (T1' ++ T2') T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , D); Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
  - intros r' r T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , A) T2) as [[D1 D2] Heq].
    { case (in_inf_app_or (vec r' D) T2 (a , A)) ; [ apply Permutation_Type_in_inf with ((a, A) :: vec s A ++ vec r B ++ T1); [ Permutation_Type_solve | left; reflexivity ] | | auto ].
      intros H; clear - H Hneq2.
      exfalso.
      induction r'; simpl in H; inversion H.
      - inversion H0.
        apply Hneq2; symmetry; apply H3.
      - apply IHr'; apply X. }
    subst.
    destruct (IHs r' r T1 (D1 ++ D2) A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , A); Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
  - intros s r' r T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , C) T1) as [[T1' T2'] Heq].
    { case (in_inf_app_or (vec s A) (vec r B ++ T1) (a , C)) ; [ apply Permutation_Type_in_inf with ((a, C) :: vec s' C ++ vec r' D ++ T2); [ Permutation_Type_solve | left; reflexivity ] | | ].
      - intros H; clear - H Hneq1.
        exfalso.
        induction s; simpl in H; inversion H.
        + inversion H0.
          apply Hneq1; apply H3.
        + apply IHs; apply X.
      - intro H0 ;case (in_inf_app_or (vec r B) T1 (a , C)) ; [ apply H0 | | auto ].
        intros H; clear - H Hneq3.
        exfalso.
        induction r; simpl in H; inversion H.
        + inversion H0; subst; apply Hneq3; reflexivity.
        + apply IHr; apply X. }
    subst.
    destruct (IHs' s r' r (T1' ++ T2') T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , C); Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
Qed.


Require Import FunctionalExtensionality JMeq.
Require Export SpecializedCategory Functor.
Require Import Common Notations FunctorAttributes FEqualDep.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Local Ltac faithful_t :=
  repeat (unfold Object in *; simpl in *; subst;
          match goal with
            | _ => intro
            | _ => progress trivial
            | [ |- _ = _ ] => (apply functional_extensionality_dep; intro)
            | _ => progress simpl_eq
            | [ H : _ = _ |- _ ] => fg_equal_in H
            (*| [ |- projT2 ?a == projT2 ?b ] =>
              (cut (projT1 a = projT1 b); [ (*generalize a b*) | faithful_t ](*;
               intros [] [] ?*))*)
            | _ => progress JMeq_eq
          end).

Section sigT_obj_mor.
  Context `(A : @SpecializedCategory objA).
  Variable Pobj : objA -> Type.
  Variable Pmor : forall s d : sigT Pobj, A.(Morphism) (projT1 s) (projT1 d) -> Type.

  Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _).
  Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2).

  Hypothesis P_Associativity : forall o1 o2 o3 o4 m1 m2 m3 m1' m2' m3',
    @Pcompose o1 o2 o4 _ m1 (@Pcompose o2 o3 o4 m3 m2 m3' m2') m1' ==
    @Pcompose o1 o3 o4 m3 _ m3' (@Pcompose o1 o2 o3 m2 m1 m2' m1').

  Hypothesis P_LeftIdentity : forall a b f f',
    @Pcompose a b b _ f (@Pidentity b) f' ==
    f'.

  Hypothesis P_RightIdentity : forall a b f f',
    @Pcompose a a b f _ f' (@Pidentity a) ==
    f'.

  Definition SpecializedCategory_sigT : @SpecializedCategory (sigT Pobj).
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => sigT (@Pmor s d))
          (fun x => existT _ (Identity (C := A) (projT1 x)) (Pidentity x))
          (fun s d d' m1 m2 => existT _ (Compose (C := A) (projT1 m1) (projT1 m2)) (Pcompose (projT2 m1) (projT2 m2)))
          _
          _
          _
        )
    end;
    abstract (intros; simpl_eq; auto with category).
  Defined.

  Definition projT1_functor : SpecializedFunctor SpecializedCategory_sigT A
    := Build_SpecializedFunctor SpecializedCategory_sigT A
                                (@projT1 _ _)
                                (fun _ _ => @projT1 _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).
End sigT_obj_mor.

Arguments projT1_functor {objA A Pobj Pmor Pidentity Pcompose P_Associativity P_LeftIdentity P_RightIdentity}.

Section sigT_obj.
  Context `(A : @SpecializedCategory objA).
  Variable Pobj : objA -> Type.

  Definition SpecializedCategory_sigT_obj : @SpecializedCategory (sigT Pobj).
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => A.(Morphism) (projT1 s) (projT1 d))
          (fun x => Identity (C := A) (projT1 x))
          (fun s d d' m1 m2 => Compose (C := A) m1 m2)
          _
          _
          _
        )
    end;
    abstract (intros; destruct_sig; simpl; auto with category).
  Defined.

  Definition projT1_obj_functor : SpecializedFunctor SpecializedCategory_sigT_obj A
    := Build_SpecializedFunctor SpecializedCategory_sigT_obj A
                                (@projT1 _ _)
                                (fun s d m => m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition SpecializedCategory_sigT_obj_as_sigT : @SpecializedCategory (sigT Pobj).
    refine (@SpecializedCategory_sigT _ A Pobj (fun _ _ _ => unit) (fun _ => tt) (fun _ _ _ _ _ _ _ => tt) _ _ _);
    abstract (simpl; intros; trivial).
  Defined.

  Definition sigT_functor_obj : SpecializedFunctor SpecializedCategory_sigT_obj_as_sigT SpecializedCategory_sigT_obj
    := Build_SpecializedFunctor SpecializedCategory_sigT_obj_as_sigT SpecializedCategory_sigT_obj
                                (fun x => x)
                                (fun _ _ => @projT1 _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition sigT_functor_obj_inv : SpecializedFunctor SpecializedCategory_sigT_obj SpecializedCategory_sigT_obj_as_sigT
    := Build_SpecializedFunctor SpecializedCategory_sigT_obj SpecializedCategory_sigT_obj_as_sigT
                                (fun x => x)
                                (fun _ _ m => existT _ m tt)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Lemma sigT_obj_eq : ComposeFunctors sigT_functor_obj sigT_functor_obj_inv = IdentityFunctor _ /\ ComposeFunctors sigT_functor_obj_inv sigT_functor_obj = IdentityFunctor _.
    split; functor_eq; hnf in *; destruct_type @sigT; f_equal; trivial.
  Qed.

  Lemma sigT_obj_compat : ComposeFunctors projT1_obj_functor sigT_functor_obj = projT1_functor.
    functor_eq.
  Qed.
End sigT_obj.

Arguments projT1_obj_functor {objA A Pobj}.

Section sigT_mor.
  Context `(A : @SpecializedCategory objA).
  Variable Pmor : forall s d, A.(Morphism) s d -> Type.

  Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _).
  Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2).

  Hypothesis P_Associativity : forall o1 o2 o3 o4 m1 m2 m3 m1' m2' m3',
    @Pcompose o1 o2 o4 _ m1 (@Pcompose o2 o3 o4 m3 m2 m3' m2') m1' ==
    @Pcompose o1 o3 o4 m3 _ m3' (@Pcompose o1 o2 o3 m2 m1 m2' m1').

  Hypothesis P_LeftIdentity : forall a b f f',
    @Pcompose a b b _ f (@Pidentity b) f' ==
    f'.

  Hypothesis P_RightIdentity : forall a b f f',
    @Pcompose a a b f _ f' (@Pidentity a) ==
    f'.

  Definition SpecializedCategory_sigT_mor : @SpecializedCategory objA.
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => sigT (@Pmor s d))
          (fun x => existT _ (Identity (C := A) x) (Pidentity x))
          (fun s d d' m1 m2 => existT _ (Compose (C := A) (projT1 m1) (projT1 m2)) (Pcompose (projT2 m1) (projT2 m2)))
          _
          _
          _
        )
    end;
    abstract (intros; simpl_eq; auto with category).
  Defined.

  Definition projT1_mor_functor : SpecializedFunctor SpecializedCategory_sigT_mor A.
    refine (Build_SpecializedFunctor SpecializedCategory_sigT_mor A
      (fun x => x)
      (fun s d m => projT1 m)
      _
      _
    );
    intros; reflexivity.
  Defined.

  Definition SpecializedCategory_sigT_mor_as_sigT : @SpecializedCategory (sigT (fun _ : objA => unit)).
    apply (@SpecializedCategory_sigT _ A _ (fun s d => @Pmor (projT1 s) (projT1 d)) (fun _ => Pidentity _) (fun _ _ _ _ _ m1 m2 => Pcompose m1 m2));
      abstract (intros; trivial).
  Defined.

  Definition sigT_functor_mor : SpecializedFunctor SpecializedCategory_sigT_mor_as_sigT SpecializedCategory_sigT_mor.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (@projT1 _ _)
          (fun _ _ => @id _)
          _
          _
        )
    end;
    simpl; intros; reflexivity.
  Defined.

  Definition sigT_functor_mor_inv : SpecializedFunctor SpecializedCategory_sigT_mor SpecializedCategory_sigT_mor_as_sigT.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (fun x => existT _ x tt)
          (fun _ _  => @id _)
          _
          _
        )
    end;
    abstract (simpl; intros; f_equal; trivial).
  Defined.

  Lemma sigT_mor_eq : ComposeFunctors sigT_functor_mor sigT_functor_mor_inv = IdentityFunctor _ /\ ComposeFunctors sigT_functor_mor_inv sigT_functor_mor = IdentityFunctor _.
    split; functor_eq; simpl_eq; trivial.
  Qed.

  Lemma sigT_mor_compat : ComposeFunctors projT1_mor_functor sigT_functor_mor = projT1_functor.
    functor_eq.
  Qed.
End sigT_mor.

Arguments projT1_mor_functor {objA A Pmor Pidentity Pcompose P_Associativity P_LeftIdentity P_RightIdentity}.