Set Implicit Arguments.

Section Reduce.
  Variable f : Type -> Type.
  Definition reducer_t := forall A B : Type, (A -> B -> B) -> (f A -> B -> B).
  Definition reducel_t := forall A B : Type, (B -> A -> B) -> (B -> f A -> B).
End Reduce.

Record Reduce (f : Type -> Type) : Type :=
  mkReduce {
    reducer : reducer_t f;
    reducel : reducel_t f
  }.

Definition idReduce := mkReduce (fun a b op => op) (fun a b op => op).

Require Import Coq.Lists.List.

Definition listReduce := mkReduce (fun a b op fa b => fold_right op b fa)
  (fun a b op b fa => fold_left op fa b).

Section toList.

  Variable f : Type -> Type.
  Variable r : Reduce f.
  Variable A : Type.

  Definition toList (x : f A) : list A :=
    (reducer r (cons (A:=A))) x nil.
End toList.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
Require Import Strings.String.
Require Import PeanoNat.
From AC Require Import nvalue.
Require Import Bool.
Require Import List.

Inductive ty : Type :=
  | Ty_Builtin : Type -> ty
  | Ty_Arrow : ty -> ty -> ty.

Inductive exp: Type :=
  | exp_var : string -> exp
  | exp_app : exp -> exp -> exp
  | exp_val : string -> exp -> exp -> exp
  | exp_if : exp -> exp -> exp -> exp
  | exp_nvalue : nvalue literal-> exp
  | exp_literal : literal -> exp
with literal :=
  | l_true : literal
  | l_false : literal
  | l_const : nat -> literal
  | l_succ : exp -> literal
  | l_pred : exp -> literal
  | l_mult : exp -> exp -> literal
  | l_abs : string -> string -> ty -> exp -> literal
  | l_nvalue_get: exp -> exp -> literal
  | l_nvalue_getDefault: exp -> literal.

Declare Custom Entry acnotation.

(*expresion*)
Notation "<{ e }>" := e (e custom acnotation at level 99).

(*variable*)
Coercion exp_var : string >-> exp.

(*lambda*)
Notation "'fun' name [ x :  t ]  { y }" :=
  (l_abs name x t y) (in custom acnotation at level 90,
                     name at level 99,
                     x at level 99,
                     t custom acnotation at level 99,
                     y custom acnotation at level 99,
                     name at level 99,
                     left associativity).

(*application*)
Notation "x y " := (exp_app x y) (in custom acnotation at level 1, left associativity).
Notation "( x )" := x (in custom acnotation, x at level 99).
Notation "x" := x (in custom acnotation at level 0, x constr at level 0).

Notation "'val' name = x ; y" := (exp_val name x y) (in custom acnotation at level 90,
                                                    name at level 99,
                                                    x custom acnotation at level 99,
                                                    y custom acnotation at level 99,
                                                    left associativity).

Notation "S -> T" := (Ty_Arrow S T) (in custom acnotation at level 50, right associativity).

(*boolean*)
Notation "'Bool'" := (Ty_Builtin bool) (in custom acnotation at level 0).
Notation "'true'" := true (at level 1).
Notation "'true'" := l_true (in custom acnotation at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := l_false (in custom acnotation at level 0).

(*natural numbers*)
Notation "'Nat'" := (Ty_Builtin nat) (in custom acnotation at level 0).
Notation "'succ' x" := (l_succ x) (in custom acnotation at level 0,
                                     x custom acnotation at level 0).
Notation "'pred' x" := (l_pred x) (in custom acnotation at level 0,
                                     x custom acnotation at level 0).
Notation "x * y" := (l_mult x y) (in custom acnotation at level 1,
                                      left associativity).
Notation "'nv_get' pos nv" := (l_nvalue_get pos nv) (in custom acnotation at level 0,
                                     nv custom acnotation at level 0,
                                     pos custom acnotation at level 0).
Notation "'nv_default' x" := (l_nvalue_getDefault x) (in custom acnotation at level 0,
                                     x custom acnotation at level 0).

Coercion exp_literal: literal >-> exp.
Coercion l_const: nat >-> literal.

(*if condition*)
Notation "'if' x 'then' y 'else' z" :=
  (exp_if x y z) (in custom acnotation at level 89,
                    x custom acnotation at level 99,
                    y custom acnotation at level 99,
                    z custom acnotation at level 99,
                    left associativity).

(*nvalues*)
Notation "[ > l ]" := (default literal l) (in custom acnotation at level 30).
Notation "[ x >> y ] m" := ( device literal x y m)(in custom acnotation at level 30,
                                            x at level 99,
                                            y at level 99,
                                            m custom acnotation at level 30).

Coercion exp_nvalue: nvalue >-> exp.

Reserved Notation "'/' x ':=' s '/' t" (in custom acnotation at level 20, x constr).
Fixpoint subst (x : string) (s : exp) (t : exp) : exp :=
  match t with
  | exp_var y =>
      if String.eqb x y then s else t
  | <{fun n [y:T] {t1}}> =>
      if ((String.eqb x y) || (String.eqb x n)) then t else <{fun n [y:T] {/x:=s/ t1}}>
  | <{t1 t2}> =>
      <{(/x:=s/ t1) (/x:=s/ t2)}>
  | <{val n = t1 ; t2}> =>
      if (String.eqb x n) then t else <{val n = (/x:=s/ t1) ; (/x:=s/ t2)}>
  | <{if t1 then t2 else t3}> =>
        <{if (/x:=s/ t1) then (/x:=s/ t2) else (/x:=s/ t3)}>
  | exp_nvalue nv =>
    <{nv}>
  | <{true}> =>
      <{true}>
  | <{false}> =>
      <{false}>
  | l_const n =>
    <{n}>
  | l_succ t1 =>
    <{succ (/x:=s/ t1)}>
  | l_pred t1 =>
    <{pred (/x:=s/ t1)}>
  | l_mult t1 t2 =>
    <{(/x:=s/ t1) * (/x:=s/ t2)}>
  | l_nvalue_get t1 t2 =>
      <{nv_get (/x:=s/ t1) (/x:=s/ t2)}>
  | l_nvalue_getDefault t1 =>
      <{nv_default (/x:=s/ t1)}>
  end
where "'/' x ':=' s '/' t" := (subst x s t) (in custom acnotation).

Fixpoint bounded (e:exp) (l_bounded:list string): Prop :=
match e with
  | exp_var y =>
    In y l_bounded
  | <{fun n [y:T] {t1}}> =>
    bounded t1 (cons y l_bounded)
  | <{t1 t2}> =>
    (bounded t1 l_bounded) /\ (bounded t1 l_bounded)
  | <{val n = t1 ; t2}> =>
    (bounded t1 l_bounded(*(cons n l_bounded)*)) /\ (bounded t2 (cons n l_bounded))
  | <{if t1 then t2 else t3}> =>
    (bounded t1 l_bounded) /\ (bounded t2 l_bounded)
    /\ (bounded t3 l_bounded)
  | exp_nvalue nv =>
    True
  | <{true}> =>
    False
  | <{false}> =>
    True
  | l_const n =>
    False
  | l_succ t1 =>
    (bounded t1 l_bounded)
  | l_pred t1 =>
    (bounded t1 l_bounded)
  | l_mult t1 t2 =>
    (bounded t1 l_bounded) /\ (bounded t2 l_bounded)
  | l_nvalue_get t1 t2 =>
      (bounded t1 l_bounded) /\ (bounded t2 l_bounded)
  | l_nvalue_getDefault t1 =>
        (bounded t1 l_bounded)
end.

Inductive value : exp -> Prop :=
  | v_abs : forall n x T2 t1, bounded <{fun n [x:T2] {t1}}> nil ->
      value <{fun n [x:T2] {t1}}>
  | v_true :
      value <{true}>
  | v_false :
      value <{false}>
  | v_nat: forall (n:nat), value <{n}>
  | v_nvalue: forall (n:nvalue literal), value <{n}>.
Hint Constructors value : core.

Inductive is_fun: exp -> Prop :=
  | func : forall n x T2 t1,
      is_fun <{fun n [x:T2] {t1}}>.


Set Primitive Projections.
Set Printing All.
Parameter T : Type.
Parameter P : T -> Type.

Module A.
  Record total2 { T: Type } ( P: T -> Type ) :=
    tpair : forall t : T , forall tp : P t , total2 P .
  Definition pr1 { T: Type } { P : T -> Type } ( tp : total2 P ) : T :=
    match tp with tpair _ t p => t end .
  Definition pr2 { T: Type } { P : T -> Type } ( tp : total2 P ) : P ( pr1 tp ) :=
    match tp as a return P ( pr1 a ) with tpair _ t p => p end .
  Definition X := total2 P.
  Parameter x : X.
  Definition x' : X := tpair _ (pr1 x) (pr2 x).
  Print x'.
  Goal x = x'.                  (* @tpair T P (@pr1 T P x) (@pr2 T P x) -- can be bulky *)
    (* reflexivity. (* fails *) *)
    admit.
  Defined.
End A.

Module B.
  Record total2 { T: Type } ( P: T -> Type ) := tpair { pr1 : T; pr2 : P pr1 }.
  Arguments tpair {T} _ _ _.
  Definition X := total2 P.
  Parameter x : X.
  Definition x' : X := tpair _ (pr1 x) (pr2 x).
  Print x'.                     (* @tpair T P (pr1 x) (pr2 x)   ! *)
  Goal x = x'.
    reflexivity.                (* ! *)
  Defined.
End B.

(*
  Local Variables:
  coq-prog-name: "~/local/encap/coq-polyproj/bin/coqtop"
  End:
*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL B FREE SOFTWARE LICENSE AGREEMENT           *)
(**************************************************************)

From Coq
  Require Import Arith List Lia.

From KruskalTrees
  Require Import notations tactics list_utils ltree.

Import ListNotations ltree_notations.

Set Implicit Arguments.

#[local] Reserved Notation "'⟨' l '⟩ᵣ'" (at level 0, l at level 200, format "⟨ l ⟩ᵣ").
#[local] Reserved Notation "'⌊' t '⌋ᵣ'" (at level 0, t at level 200, format "⌊ t ⌋ᵣ").

(** Undecorated rose trees *)

Unset Elimination Schemes.
Inductive rtree := rt : list rtree -> rtree.
Set Elimination Schemes.

#[local] Notation "⟨ l ⟩ᵣ" := (rt l).

Section rtree_rect.

  Let ist_wf : well_founded (fun s t => match t with ⟨l⟩ᵣ => s ∈ l end).
  Proof.
    refine (fix loop t := _).
    destruct t as [ l ].
    constructor 1.
    induction l as [ | s l IHl ].
    + intros ? [].
    + intros x [ <- | Hx ].
      * apply loop.
      * apply IHl, Hx.
  Qed.

  Variables (P : rtree -> Type)
            (HP : forall l, (forall t, t ∈ l -> P t) -> P ⟨l⟩ᵣ).

  Theorem rtree_rect t : P t.
  Proof.
    generalize (ist_wf t); revert t.
    refine (fix loop t d { struct d } := _).
    destruct t as [ l ]; apply HP.
    intros s Hs; apply loop.
    apply Acc_inv with (1 := d), Hs.
  Qed.

End rtree_rect.

Definition rtree_rec (P : _ -> Set) := @rtree_rect P.
Definition rtree_ind (P : _ -> Prop) := @rtree_rect P.

Fixpoint rtree_size (r : rtree) : nat.
Proof.
  destruct r as [ l ].
  apply (plus 1).
  induction l as [ | t l IHl ].
  + exact 0.
  + apply (rtree_size t + IHl).
Defined.

Fact rtree_size_fix l : rtree_size ⟨l⟩ᵣ = 1+list_sum rtree_size l.
Proof. induction l; simpl; f_equal; auto. Qed.

Module rtree_notations.

  Notation "⟨ l ⟩ᵣ" := (rt l).
  Notation "⌊ t ⌋ᵣ" := (rtree_size t).

End rtree_notations.

Import rtree_notations.

Fact rtree_size_gt t : 0 < ⌊t⌋ᵣ.
Proof. destruct t; rewrite rtree_size_fix; lia. Qed.

Definition ltree_rtree : ltree unit -> rtree.
Proof. apply ltree_recursion; intros _ _; apply rt. Defined.

Fact ltree_rtee_surj (t : rtree) : { t' | ltree_rtree t' = t }.
Proof.
  induction t as [ l IHl ].
  Forall reif IHl as (m & Hm).
  exists ⟨tt|m⟩ₗ; simpl; f_equal.
  now rewrite Forall2_xchg, <- Forall2_map_left, Forall2_eq in Hm.
Qed.


Load "IFMORPH".
(******************andB properties***********)

Lemma andB_FAlse_intro1 : forall b1 b2 : Bool, b1 ## FAlse -> b1 & b2 ## FAlse.

Proof.
intros.
unfold andB .
rewrite H.
apply IFFALSE_B.
Qed.
Lemma andB_FAlse_intro2 : forall b1 b2:Bool, b2 ## FAlse -> b1 & b2 ## FAlse.
Proof. intros. unfold andB. rewrite H. apply IFSAME_B. Qed.

Lemma andB_FAlse_r :  forall b:Bool, b & FAlse ## FAlse.

Proof. intros.  unfold andB. apply IFSAME_B. Qed.

Lemma andB_FAlse_l : forall b: Bool, FAlse & b ## FAlse.
Proof. intros. unfold andB. apply IFFALSE_B. Qed.

Lemma andB_diag : forall n, (Bvar n) & (Bvar n) ## (Bvar n).
Proof.  intros. unfold andB. rewrite IFEVAL_B. simpl.
rewrite <- beq_nat_refl.
 rewrite IFTF.
reflexivity.
Qed.

Lemma andB_TRue_r : forall b:Bool, b & TRue ## b.

Proof.  intros. unfold andB.
pose proof (IFTF 1).
apply Forall_ELM_EVAL_B with (n :=1)(b:=b) in H.
simpl in H.
apply H.  Qed.

Lemma andB_TRue_l : forall b:Bool,  TRue & b ## b.

Proof.  intros. unfold andB.
apply IFTRUE_B.
   Qed.

Lemma andB_notb_r : forall n, (Bvar n) & (notb (Bvar n)) ## FAlse.

Proof. intros. unfold andB .  unfold notb.  rewrite IFEVAL_B. simpl. rewrite <- beq_nat_refl.
rewrite IFTRUE_B. rewrite IFSAME_B. reflexivity. Qed.

Lemma andB_comm1: forall n1 n2 , ( (Bvar n1) & (Bvar n2))  ## ( (Bvar n2) & (Bvar n1)).

Proof. intros. unfold andB.  rewrite <- IFTF with (n:= n2) at 1 .

rewrite IFMORPH_B1 with (n1:= n2) (n2:=n1). rewrite IFTF with (n:= n1). rewrite IFSAME_B. reflexivity. Qed.

Axiom andB_comm: forall (b1 b2: Bool), (b1 & b2) ## (b2 & b1).
(**
Proof. pose proof(andB_comm1 0 ).
intros.
apply Forall_ELM_EVAL_B with (n:= 0) (b := b1) in H.
apply Forall_ELM_EVAL_B with (n:= 1) (b := b2) in H.
simpl in H.
rewrite andB_comm1 in H.
simpl in H.
*)
(************************************************************)
 Lemma andB_assoc1 : forall n1 n2 n3, (Bvar n1) & ((Bvar n2) & (Bvar n3)) ##( ((Bvar n1) & (Bvar n2)) & (Bvar n3)).

 Proof. intros. unfold andB.
pose proof(andB_comm1).
unfold andB in H.

pose proof (IFMORPH_B1).
 rewrite IFMORPH_B1 with (n1:= n2) (n2:= n1).
rewrite H with (n1:=n1) (n2:= n2).
rewrite IFMORPH_B2.
rewrite IFSAME_B.
rewrite IFFALSE_B.
reflexivity.
Qed.

Axiom andB_assoc: forall (b1 b2 b3: Bool), (b1 & b2) & b3 ## b1 & (b2 & b3).
 Lemma andB_prop : forall a b:Bool, (andB a b) ## TRue -> (a ## TRue) /\ (b ## TRue).

Proof.
intros.
unfold andB in H.
pose proof(IFSAME_B b (if_then_else_B a b FAlse)).
Admitted.
Lemma andB_TRue_intro :
  forall b1 b2:Bool, b1 ## TRue /\ b2 ## TRue -> (andB b1 b2) ## TRue.

Proof. intros.
inversion H.
unfold andB.
rewrite H0.
rewrite IFTRUE_B.
assumption.
Qed.

Lemma andB_TRue_iff :  forall n1 n2, (Bvar n1) & (Bvar n2) ## TRue <-> (Bvar n1) ## TRue /\ (Bvar n2) ## TRue.
Proof. split.
apply andB_prop.
apply andB_TRue_intro.

Qed.

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

Lemma notB_involutive : forall n, (notb (notb (Bvar n))) ## (Bvar n).

Proof. intros. unfold notb.

 rewrite IFMORPH_B2. rewrite IFFALSE_B. rewrite IFTRUE_B.
rewrite IFTF. reflexivity. Qed.

Lemma notB_TRue_iff : forall n, ( notb (Bvar n)) ## TRue <-> (Bvar n) ## FAlse.
Proof.
intros. split.
intros.
rewrite <- notB_involutive.
rewrite H.
unfold notb .
rewrite IFTRUE_B.
reflexivity.
intros.
rewrite H.
unfold notb.
rewrite IFFALSE_B.
reflexivity.
Qed.

Lemma notb_FAlse_iff : forall n, (notb (Bvar n)) ## FAlse <-> (Bvar n) ## TRue.

Proof. intros. split.

intros.  rewrite <- notB_involutive. rewrite H. unfold notb. rewrite IFFALSE_B.  reflexivity.

intros. rewrite H. unfold notb.

rewrite IFTRUE_B. reflexivity. Qed.

(********************andB complementation************)

Lemma and_notB_r : forall n, (Bvar n) & (notb (Bvar n)) ## FAlse.
Proof. intros. unfold  andB.
unfold notb. rewrite IFMORPH_B1.
rewrite IFIDEMP_B. rewrite IFSAME_B. reflexivity. Qed.

Lemma and_notB_l : forall n, (notb (Bvar n)) & (Bvar n) ## FAlse.
Proof. intros. unfold  andB.
unfold notb. rewrite IFMORPH_B2.
rewrite IFFALSE_B, IFTRUE_B.
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFSAME_B.
reflexivity. Qed.

Theorem b1_notb2 : forall (n1 : nat) , (Bvar n1) &(notb (Bvar (n1+1))) ##
(if_then_else_B (Bvar (n1+1)) FAlse (Bvar n1)) .

Proof.
 intros.

unfold notb, andB.

rewrite <- IFSAME_B with (b:= (Bvar (n1+1))) (b1:= (if_then_else_B (Bvar n1) (if_then_else_B (Bvar (n1 + 1)) FAlse TRue) FAlse)).

rewrite IFEVAL_B with (n := (n1+1)).
 simpl.
rewrite <- beq_nat_refl.
rewrite IFFALSE_B.
rewrite IFTRUE_B.
rewrite IFSAME_B.
(*************)
assert(H: beq_nat n1 (n1 + 1) = false).
induction n1.
reflexivity.
simpl.
assumption.
(************)
rewrite H.
rewrite IFTF.
reflexivity.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about disjoint unions *)

Require Import HoTT.Basics.
Require Import Types.Empty Types.Unit Types.Prod Types.Sigma.
(** The following are only required for the equivalence between [sum] and a sigma type *)
Require Import Types.Bool Types.Forall.

Local Open Scope trunc_scope.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

Scheme sum_ind := Induction for sum Sort Type.
Arguments sum_ind {A B} P f g s : rename.

(** ** CoUnpacking *)

(** Sums are coproducts, so there should be a dual to [unpack_prod].  I'm not sure what it is, though. *)

(** ** Eta conversion *)

Definition eta_sum `(z : A + B) : match z with
                                    | inl z' => inl z'
                                    | inr z' => inr z'
                                  end = z
  := match z with inl _ => 1 | inr _ => 1 end.

(** ** Paths *)

Definition path_sum {A B : Type} (z z' : A + B)
           (pq : match z, z' with
                   | inl z0, inl z'0 => z0 = z'0
                   | inr z0, inr z'0 => z0 = z'0
                   | _, _ => Empty
                 end)
: z = z'.
  destruct z, z'.
  all:try apply ap, pq.
  all:elim pq.
Defined.

Definition path_sum_inv {A B : Type} {z z' : A + B}
           (pq : z = z')
: match z, z' with
    | inl z0, inl z'0 => z0 = z'0
    | inr z0, inr z'0 => z0 = z'0
    | _, _ => Empty
  end
  := match pq with
       | 1 => match z with
                | inl _ => 1
                | inr _ => 1
              end
     end.

Definition inl_ne_inr {A B : Type} (a : A) (b : B)
: inl a <> inr b
:= path_sum_inv.

Definition inr_ne_inl {A B : Type} (b : B) (a : A)
: inr b <> inl a
:= path_sum_inv.

(** This version produces only paths between closed terms, as opposed to paths between arbitrary inhabitants of sum types. *)
Definition path_sum_inl {A : Type} (B : Type) {x x' : A}
: inl x = inl x' -> x = x'
  := fun p => @path_sum_inv A B _ _ p.

Definition path_sum_inr (A : Type) {B : Type} {x x' : B}
: inr x = inr x' -> x = x'
  := fun p => @path_sum_inv A B _ _ p.

(** This lets us identify the path space of a sum type, up to equivalence. *)

Definition eisretr_path_sum {A B} {z z' : A + B}
: (path_sum z z') o (@path_sum_inv _ _ z z') == idmap
  := fun p => match p as p in (_ = z') return
                    path_sum z z' (path_sum_inv p) = p
              with
                | 1 => match z as z return
                             path_sum z z (path_sum_inv 1) = 1
                       with
                         | inl _ => 1
                         | inr _ => 1
                       end
              end.

Definition eissect_path_sum {A B} {z z' : A + B}
: (@path_sum_inv _ _ z z') o (path_sum z z') == idmap.
Proof.
  intro p.
  destruct z, z', p; exact idpath.
Defined.

Global Instance isequiv_path_sum {A B : Type} {z z' : A + B}
: IsEquiv (path_sum z z') | 0.
Proof.
  refine (Build_IsEquiv _ _
                       (path_sum z z')
                       (@path_sum_inv _ _ z z')
                       (@eisretr_path_sum A B z z')
                       (@eissect_path_sum A B z z')
                       _).
  destruct z, z';
    intros [];
    exact idpath.
Defined.

Definition equiv_path_sum {A B : Type} (z z' : A + B)
  := Build_Equiv _ _ _ (@isequiv_path_sum A B z z').

(** ** Fibers of [inl] and [inr] *)

(** It follows that the fibers of [inl] and [inr] are decidable hprops. *)

Global Instance ishprop_hfiber_inl {A B : Type} (z : A + B)
: IsHProp (hfiber inl z).
Proof.
  destruct z as [a|b]; unfold hfiber.
  - refine (istrunc_equiv_istrunc _
              (equiv_functor_sigma_id
                 (fun x => equiv_path_sum (inl x) (inl a)))).
  - refine (istrunc_isequiv_istrunc _
              (fun xp => inl_ne_inr (xp.1) b xp.2)^-1).
Defined.

Global Instance decidable_hfiber_inl {A B : Type} (z : A + B)
: Decidable (hfiber inl z).
Proof.
  destruct z as [a|b]; unfold hfiber.
  - refine (decidable_equiv' _
              (equiv_functor_sigma_id
                 (fun x => equiv_path_sum (inl x) (inl a))) _).
  - refine (decidable_equiv _
              (fun xp => inl_ne_inr (xp.1) b xp.2)^-1 _).
Defined.

Global Instance ishprop_hfiber_inr {A B : Type} (z : A + B)
: IsHProp (hfiber inr z).
Proof.
  destruct z as [a|b]; unfold hfiber.
  - refine (istrunc_isequiv_istrunc _
              (fun xp => inr_ne_inl (xp.1) a xp.2)^-1).
  - refine (istrunc_equiv_istrunc _
              (equiv_functor_sigma_id
                 (fun x => equiv_path_sum (inr x) (inr b)))).
Defined.

Global Instance decidable_hfiber_inr {A B : Type} (z : A + B)
: Decidable (hfiber inr z).
Proof.
  destruct z as [a|b]; unfold hfiber.
  - refine (decidable_equiv _
              (fun xp => inr_ne_inl (xp.1) a xp.2)^-1 _).
  - refine (decidable_equiv' _
              (equiv_functor_sigma_id
                 (fun x => equiv_path_sum (inr x) (inr b))) _).
Defined.

(** ** Decomposition *)

(** Conversely, a decidable predicate decomposes a type as a sum. *)

Section DecidableSum.
  Context `{Funext} {A : Type} (P : A -> Type)
          `{forall a, IsHProp (P a)} `{forall a, Decidable (P a)}.

  Definition equiv_decidable_sum
    : A <~> {x:A & P x} + {x:A & ~(P x)}.
  Proof.
    transparent assert (f : (A -> {x:A & P x} + {x:A & ~(P x)})).
    { intros x.
      destruct (dec (P x)) as [p|np].
      - exact (inl (x;p)).
      - exact (inr (x;np)). }
    refine (Build_Equiv _ _ f _).
    refine (isequiv_adjointify
              _ (fun z => match z with
                          | inl (x;p) => x
                          | inr (x;np) => x
                          end) _ _).
    - intros [[x p]|[x np]]; unfold f;
        destruct (dec (P x)) as [p'|np'].
      + apply ap, ap, path_ishprop.
      + elim (np' p).
      + elim (np p').
      + apply ap, ap, path_ishprop.
    - intros x; unfold f.
      destruct (dec (P x)); cbn; reflexivity.
  Defined.

  Definition equiv_decidable_sum_l (a : A) (p : P a)
    : equiv_decidable_sum a = inl (a;p).
  Proof.
    unfold equiv_decidable_sum; cbn.
    destruct (dec (P a)) as [p'|np'].
    - apply ap, path_sigma_hprop; reflexivity.
    - elim (np' p).
  Defined.

  Definition equiv_decidable_sum_r (a : A) (np : ~ (P a))
    : equiv_decidable_sum a = inr (a;np).
  Proof.
    unfold equiv_decidable_sum; cbn.
    destruct (dec (P a)) as [p'|np'].
    - elim (np p').
    - apply ap, path_sigma_hprop; reflexivity.
  Defined.

End DecidableSum.

(** ** Transport *)

Definition transport_sum {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
           (z : P a + Q a)
: transport (fun a => P a + Q a) p z = match z with
                                         | inl z' => inl (p # z')
                                         | inr z' => inr (p # z')
                                       end
  := match p with idpath => match z with inl _ => 1 | inr _ => 1 end end.

(** ** Detecting the summands *)

Definition is_inl_and {A B} (P : A -> Type@{p}) : A + B -> Type@{p}
  := fun x => match x with inl a => P a | inr _ => Empty end.

Definition is_inr_and {A B} (P : B -> Type@{p}) : A + B -> Type@{p}
  := fun x => match x with inl _ => Empty | inr b => P b end.

Definition is_inl {A B} : A + B -> Type0
  := is_inl_and (fun _ => Unit).

Definition is_inr {A B} : A + B -> Type0
  := is_inr_and (fun _ => Unit).

Global Instance ishprop_is_inl {A B} (x : A + B)
: IsHProp (is_inl x).
Proof.
  destruct x; exact _.
Defined.

Global Instance ishprop_is_inr {A B} (x : A + B)
: IsHProp (is_inr x).
Proof.
  destruct x; exact _.
Defined.

Global Instance decidable_is_inl {A B} (x : A + B)
: Decidable (is_inl x).
Proof.
  destruct x; exact _.
Defined.

Global Instance decidable_is_inr {A B} (x : A + B)
: Decidable (is_inr x).
Proof.
  destruct x; exact _.
Defined.

Definition un_inl {A B} (z : A + B)
: is_inl z -> A.
Proof.
  destruct z as [a|b].
  - intros; exact a.
  - intros e; elim e.
Defined.

Definition un_inr {A B} (z : A + B)
: is_inr z -> B.
Proof.
  destruct z as [a|b].
  - intros e; elim e.
  - intros; exact b.
Defined.

Definition is_inl_not_inr {A B} (x : A + B)  (na : ~ A)
: is_inr x
  := match x with
     | inl a => na a
     | inr b => tt
     end.

Definition is_inr_not_inl {A B} (x : A + B)  (nb : ~ B)
: is_inl x
  := match x with
     | inl a => tt
     | inr b => nb b
     end.

Definition un_inl_inl {A B : Type} (a : A) (w : is_inl (inl a))
: un_inl (@inl A B a) w = a
  := 1.

Definition un_inr_inr {A B : Type} (b : B) (w : is_inr (inr b))
: un_inr (@inr A B b) w = b
  := 1.

Definition inl_un_inl {A B : Type} (z : A + B) (w : is_inl z)
: inl (un_inl z w) = z.
Proof.
  destruct z as [a|b]; simpl.
  - reflexivity.
  - elim w.
Defined.

Definition inr_un_inr {A B : Type} (z : A + B) (w : is_inr z)
: inr (un_inr z w) = z.
Proof.
  destruct z as [a|b]; simpl.
  - elim w.
  - reflexivity.
Defined.

Definition not_is_inl_and_inr {A B} (P : A -> Type) (Q : B -> Type)
           (x : A + B)
: is_inl_and P x -> is_inr_and Q x -> Empty.
Proof.
  destruct x as [a|b]; simpl.
  - exact (fun _ e => e).
  - exact (fun e _ => e).
Defined.

Definition not_is_inl_and_inr' {A B} (x : A + B)
: is_inl x -> is_inr x -> Empty
  := not_is_inl_and_inr (fun _ => Unit) (fun _ => Unit) x.

Definition is_inl_or_is_inr {A B} (x : A + B)
: (is_inl x) + (is_inr x)
  := match x return (is_inl x) + (is_inr x) with
       | inl _ => inl tt
       | inr _ => inr tt
     end.

Definition is_inl_ind {A B : Type} (P : A + B -> Type)
           (f : forall a:A, P (inl a))
: forall (x:A+B), is_inl x -> P x.
Proof.
  intros [a|b] H; [ exact (f a) | elim H ].
Defined.

Definition is_inr_ind {A B : Type} (P : A + B -> Type)
           (f : forall b:B, P (inr b))
: forall (x:A+B), is_inr x -> P x.
Proof.
  intros [a|b] H; [ elim H | exact (f b) ].
Defined.

(** ** Functorial action *)

Section FunctorSum.
  Context {A A' B B' : Type} (f : A -> A') (g : B -> B').

  Definition functor_sum : A + B -> A' + B'
    := fun z => match z with inl z' => inl (f z') | inr z' => inr (g z') end.

  (** The fibers of [functor_sum] are those of [f] and [g]. *)
  Definition hfiber_functor_sum_l (a' : A')
  : hfiber functor_sum (inl a') <~> hfiber f a'.
  Proof.
    simple refine (equiv_adjointify _ _ _ _).
    - intros [[a|b] p].
      + exists a.
        exact (path_sum_inl _ p).
      + elim (inr_ne_inl _ _ p).
    - intros [a p].
      exists (inl a).
      exact (ap inl p).
    - intros [a p].
      apply ap.
      (** Why doesn't Coq find this? *)
      pose (@isequiv_path_sum A' B' (inl (f a)) (inl a')).
      exact (eissect (@path_sum A' B' (inl (f a)) (inl a')) p).
    - intros [[a|b] p]; simpl.
      + apply ap.
        pose (@isequiv_path_sum A' B' (inl (f a)) (inl a')).
        exact (eisretr (@path_sum A' B' (inl (f a)) (inl a')) p).
      + elim (inr_ne_inl _ _ p).
  Defined.

  Definition hfiber_functor_sum_r (b' : B')
  : hfiber functor_sum (inr b') <~> hfiber g b'.
  Proof.
    simple refine (equiv_adjointify _ _ _ _).
    - intros [[a|b] p].
      + elim (inl_ne_inr _ _ p).
      + exists b.
        exact (path_sum_inr _ p).
    - intros [b p].
      exists (inr b).
      exact (ap inr p).
    - intros [b p].
      apply ap.
      (** Why doesn't Coq find this? *)
      pose (@isequiv_path_sum A' B' (inr (g b)) (inr b')).
      exact (eissect (@path_sum A' B' (inr (g b)) (inr b')) p).
    - intros [[a|b] p]; simpl.
      + elim (inl_ne_inr _ _ p).
      + apply ap.
        pose (@isequiv_path_sum A' B' (inr (g b)) (inr b')).
        exact (eisretr (@path_sum A' B' (inr (g b)) (inr b')) p).
  Defined.

End FunctorSum.

Definition functor_sum_homotopic {A A' B B' : Type}
  {f f' : A -> A'} {g g' : B -> B'} (p : f == f') (q : g == g')
  : functor_sum f g == functor_sum f' g'.
Proof.
  intros [a|b].
  - exact (ap inl (p a)).
  - exact (ap inr (q b)).
Defined.

(** ** "Unfunctorial action" *)

(** Not every function [A + B -> A' + B'] is of the form [functor_sum f g].  However, this is the case if it preserves the summands, i.e. if it maps [A] into [A'] and [B] into [B'].  More generally, if a function [A + B -> A' + B'] maps [A] into [A'] only, then we can extract from it a function [A -> A'].  Since these operations are a sort of inverse to [functor_sum], we call them [unfunctor_sum_*]. *)

Definition unfunctor_sum_l {A A' B B' : Type} (h : A + B -> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
: A -> A'
  := fun a => un_inl (h (inl a)) (Ha a).

Definition unfunctor_sum_r {A A' B B' : Type} (h : A + B -> A' + B')
           (Hb : forall b:B, is_inr (h (inr b)))
: B -> B'
  := fun b => un_inr (h (inr b)) (Hb b).

Definition unfunctor_sum_eta {A A' B B' : Type} (h : A + B -> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
: functor_sum (unfunctor_sum_l h Ha) (unfunctor_sum_r h Hb) == h.
Proof.
  intros [a|b]; simpl.
  - unfold unfunctor_sum_l; apply inl_un_inl.
  - unfold unfunctor_sum_r; apply inr_un_inr.
Defined.

Definition unfunctor_sum_l_beta {A A' B B' : Type} (h : A + B -> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
: inl o unfunctor_sum_l h Ha == h o inl.
Proof.
  intros a; unfold unfunctor_sum_l; apply inl_un_inl.
Defined.

Definition unfunctor_sum_r_beta {A A' B B' : Type} (h : A + B -> A' + B')
           (Hb : forall b:B, is_inr (h (inr b)))
: inr o unfunctor_sum_r h Hb == h o inr.
Proof.
  intros b; unfold unfunctor_sum_r; apply inr_un_inr.
Defined.

Definition unfunctor_sum_l_compose {A A' A'' B B' B'' : Type}
           (h : A + B -> A' + B') (k : A' + B' -> A'' + B'')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Ha' : forall a':A', is_inl (k (inl a')))
: unfunctor_sum_l k Ha' o unfunctor_sum_l h Ha
  == unfunctor_sum_l (k o h)
     (fun a => is_inl_ind (fun x' => is_inl (k x')) Ha' (h (inl a)) (Ha a)).
Proof.
  intros a.
  refine (path_sum_inl B'' _).
  refine (unfunctor_sum_l_beta _ _ _ @ _).
  refine (ap k (unfunctor_sum_l_beta _ _ _) @ _).
  refine ((unfunctor_sum_l_beta _ _ _)^).
Defined.

Definition unfunctor_sum_r_compose {A A' A'' B B' B'' : Type}
           (h : A + B -> A' + B') (k : A' + B' -> A'' + B'')
           (Hb : forall b:B, is_inr (h (inr b)))
           (Hb' : forall b':B', is_inr (k (inr b')))
: unfunctor_sum_r k Hb' o unfunctor_sum_r h Hb
  == unfunctor_sum_r (k o h)
     (fun b => is_inr_ind (fun x' => is_inr (k x')) Hb' (h (inr b)) (Hb b)).
Proof.
  intros b.
  refine (path_sum_inr A'' _).
  refine (unfunctor_sum_r_beta _ _ _ @ _).
  refine (ap k (unfunctor_sum_r_beta _ _ _) @ _).
  refine ((unfunctor_sum_r_beta _ _ _)^).
Defined.

(** [unfunctor_sum] also preserves fibers, if both summands are preserved. *)
Definition hfiber_unfunctor_sum_l {A A' B B' : Type}
           (h : A + B -> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
           (a' : A')
: hfiber (unfunctor_sum_l h Ha) a' <~> hfiber h (inl a').
Proof.
  simple refine (equiv_adjointify _ _ _ _).
  - intros [a p].
    exists (inl a).
    refine (_ @ ap inl p).
    symmetry; apply inl_un_inl.
  - intros [[a|b] p].
    + exists a.
      apply path_sum_inl with B'.
      refine (_ @ p).
      apply inl_un_inl.
    + specialize (Hb b).
      abstract (rewrite p in Hb; elim Hb).
  - intros [[a|b] p]; simpl.
    + apply ap.
      apply moveR_Vp.
      exact (eisretr (@path_sum A' B' _ _)
                     (inl_un_inl (h (inl a)) (Ha a) @ p)).
    + apply Empty_rec.
      specialize (Hb b).
      abstract (rewrite p in Hb; elim Hb).
  - intros [a p].
    apply ap.
    rewrite concat_p_Vp.
    pose (@isequiv_path_sum
            A' B' (inl (unfunctor_sum_l h Ha a)) (inl a')).
    exact (eissect (@path_sum A' B' (inl (unfunctor_sum_l h Ha a)) (inl a')) p).
Defined.

Definition hfiber_unfunctor_sum_r {A A' B B' : Type}
           (h : A + B -> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
           (b' : B')
: hfiber (unfunctor_sum_r h Hb) b' <~> hfiber h (inr b').
Proof.
  simple refine (equiv_adjointify _ _ _ _).
  - intros [b p].
    exists (inr b).
    refine (_ @ ap inr p).
    symmetry; apply inr_un_inr.
  - intros [[a|b] p].
    + specialize (Ha a).
      abstract (rewrite p in Ha; elim Ha).
    + exists b.
      apply path_sum_inr with A'.
      refine (_ @ p).
      apply inr_un_inr.
  - intros [[a|b] p]; simpl.
    + apply Empty_rec.
      specialize (Ha a).
      abstract (rewrite p in Ha; elim Ha).
    + apply ap.
      apply moveR_Vp.
      exact (eisretr (@path_sum A' B' _ _)
                     (inr_un_inr (h (inr b)) (Hb b) @ p)).
  - intros [b p].
    apply ap.
    rewrite concat_p_Vp.
    pose (@isequiv_path_sum
            A' B' (inr (unfunctor_sum_r h Hb b)) (inr b')).
    exact (eissect (@path_sum A' B' (inr (unfunctor_sum_r h Hb b)) (inr b')) p).
Defined.

(** ** Functoriality on equivalences *)

Global Instance isequiv_functor_sum `{IsEquiv A A' f} `{IsEquiv B B' g}
: IsEquiv (functor_sum f g) | 1000.
Proof.
  apply (isequiv_adjointify
           (functor_sum f g)
           (functor_sum f^-1 g^-1));
  [ intros [?|?]; simpl; apply ap; apply eisretr
  | intros [?|?]; simpl; apply ap; apply eissect ].
Defined.

Definition equiv_functor_sum `{IsEquiv A A' f} `{IsEquiv B B' g}
: A + B <~> A' + B'
  := Build_Equiv _ _ (functor_sum f g) _.

Definition equiv_functor_sum' {A A' B B' : Type} (f : A <~> A') (g : B <~> B')
: A + B <~> A' + B'
  := equiv_functor_sum (f := f) (g := g).

Notation "f +E g" := (equiv_functor_sum' f g) : equiv_scope.

Definition equiv_functor_sum_l {A B B' : Type} (g : B <~> B')
: A + B <~> A + B'
  := 1 +E g.

Definition equiv_functor_sum_r {A A' B : Type} (f : A <~> A')
: A + B <~> A' + B
  := f +E 1.

(** ** Unfunctoriality on equivalences *)

Global Instance isequiv_unfunctor_sum_l {A A' B B' : Type}
           (h : A + B <~> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
: IsEquiv (unfunctor_sum_l h Ha).
Proof.
  simple refine (isequiv_adjointify _ _ _ _).
  - refine (unfunctor_sum_l h^-1 _); intros a'.
    remember (h^-1 (inl a')) as x eqn:p.
    destruct x as [a|b].
    + exact tt.
    + apply moveL_equiv_M in p.
      elim (p^ # (Hb b)).
  - intros a'.
    refine (unfunctor_sum_l_compose _ _ _ _ _ @ _).
    refine (path_sum_inl B' _).
    refine (unfunctor_sum_l_beta _ _ _ @ _).
    apply eisretr.
  - intros a.
    refine (unfunctor_sum_l_compose _ _ _ _ _ @ _).
    refine (path_sum_inl B _).
    refine (unfunctor_sum_l_beta (h^-1 o h) _ a @ _).
    apply eissect.
Defined.

Definition equiv_unfunctor_sum_l {A A' B B' : Type}
           (h : A + B <~> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
: A <~> A'
  := Build_Equiv _ _ (unfunctor_sum_l h Ha)
                (isequiv_unfunctor_sum_l h Ha Hb).

Global Instance isequiv_unfunctor_sum_r {A A' B B' : Type}
           (h : A + B <~> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
: IsEquiv (unfunctor_sum_r h Hb).
Proof.
  simple refine (isequiv_adjointify _ _ _ _).
  - refine (unfunctor_sum_r h^-1 _); intros b'.
    remember (h^-1 (inr b')) as x eqn:p.
    destruct x as [a|b].
    + apply moveL_equiv_M in p.
      elim (p^ # (Ha a)).
    + exact tt.
  - intros b'.
    refine (unfunctor_sum_r_compose _ _ _ _ _ @ _).
    refine (path_sum_inr A' _).
    refine (unfunctor_sum_r_beta _ _ _ @ _).
    apply eisretr.
  - intros b.
    refine (unfunctor_sum_r_compose _ _ _ _ _ @ _).
    refine (path_sum_inr A _).
    refine (unfunctor_sum_r_beta (h^-1 o h) _ b @ _).
    apply eissect.
Defined.

Definition equiv_unfunctor_sum_r {A A' B B' : Type}
           (h : A + B <~> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
: B <~> B'
  := Build_Equiv _ _ (unfunctor_sum_r h Hb)
                (isequiv_unfunctor_sum_r h Ha Hb).

Definition equiv_unfunctor_sum {A A' B B' : Type}
           (h : A + B <~> A' + B')
           (Ha : forall a:A, is_inl (h (inl a)))
           (Hb : forall b:B, is_inr (h (inr b)))
: (A <~> A') * (B <~> B')
  := (equiv_unfunctor_sum_l h Ha Hb , equiv_unfunctor_sum_r h Ha Hb).

(** ** Symmetry *)

(* This is a special property of [sum], of course, not an instance of a general family of facts about types. *)

Definition equiv_sum_symm (A B : Type) : A + B <~> B + A.
Proof.
  apply (equiv_adjointify
           (fun ab => match ab with inl a => inr a | inr b => inl b end)
           (fun ab => match ab with inl a => inr a | inr b => inl b end));
  intros [?|?]; exact idpath.
Defined.

(** ** Associativity *)

Definition equiv_sum_assoc (A B C : Type) : (A + B) + C <~> A + (B + C).
Proof.
  simple refine (equiv_adjointify _ _ _ _).
  - intros [[a|b]|c];
    [ exact (inl a) | exact (inr (inl b)) | exact (inr (inr c)) ].
  - intros [a|[b|c]];
    [ exact (inl (inl a)) | exact (inl (inr b)) | exact (inr c) ].
  - intros [a|[b|c]]; reflexivity.
  - intros [[a|b]|c]; reflexivity.
Defined.

(** ** Identity *)

Definition sum_empty_l (A : Type) : Empty + A <~> A.
Proof.
  refine (equiv_adjointify
       (fun z => match z:Empty+A with
                   | inl e => match e with end
                   | inr a => a
                 end)
       inr (fun a => 1) _).
  intros [e|z]; [ elim e | reflexivity ].
Defined.

Definition sum_empty_r (A : Type) : A + Empty <~> A.
Proof.
  refine (equiv_adjointify
       (fun z => match z : A + Empty with
                   | inr e => match e with end
                   | inl a => a
                 end)
       inl (fun a => 1) _).
  intros [z|e]; [ reflexivity | elim e ].
Defined.

(** ** Distributivity *)

Definition sum_distrib_l A B C
: A * (B + C) <~> (A * B) + (A * C).
Proof.
  refine (Build_Equiv (A * (B + C)) ((A * B) + (A * C))
            (fun abc => let (a,bc) := abc in
                        match bc with
                          | inl b => inl (a,b)
                          | inr c => inr (a,c)
                        end) _).
  simple refine (Build_IsEquiv (A * (B + C)) ((A * B) + (A * C)) _
            (fun ax => match ax with
                         | inl (a,b) => (a,inl b)
                         | inr (a,c) => (a,inr c)
                       end) _ _ _).
  - intros [[a b]|[a c]]; reflexivity.
  - intros [a [b|c]]; reflexivity.
  - intros [a [b|c]]; reflexivity.
Defined.

Definition sum_distrib_r A B C
: (B + C) * A <~> (B * A) + (C * A).
Proof.
  refine (Build_Equiv ((B + C) * A) ((B * A) + (C * A))
            (fun abc => let (bc,a) := abc in
                        match bc with
                          | inl b => inl (b,a)
                          | inr c => inr (c,a)
                        end) _).
  simple refine (Build_IsEquiv ((B + C) * A) ((B * A) + (C * A)) _
            (fun ax => match ax with
                         | inl (b,a) => (inl b,a)
                         | inr (c,a) => (inr c,a)
                       end) _ _ _).
  - intros [[b a]|[c a]]; reflexivity.
  - intros [[b|c] a]; reflexivity.
  - intros [[b|c] a]; reflexivity.
Defined.

(** ** Extensivity *)

(** We can phrase extensivity in two ways, using either dependent types or functions. *)

(** The first is a statement about types dependent on a sum type. *)
Definition equiv_sigma_sum A B (C : A + B -> Type)
: { x : A+B & C x } <~>
  { a : A & C (inl a) } + { b : B & C (inr b) }.
Proof.
  refine (Build_Equiv { x : A+B & C x }
                     ({ a : A & C (inl a) } + { b : B & C (inr b) })
           (fun xc => let (x,c) := xc in
                      match x return
                            C x -> ({ a : A & C (inl a) } + { b : B & C (inr b) })
                      with
                        | inl a => fun c => inl (a;c)
                        | inr b => fun c => inr (b;c)
                      end c) _).
  simple refine (Build_IsEquiv { x : A+B & C x }
                       ({ a : A & C (inl a) } + { b : B & C (inr b) }) _
           (fun abc => match abc with
                         | inl (a;c) => (inl a ; c)
                         | inr (b;c) => (inr b ; c)
                       end) _ _ _).
  - intros [[a c]|[b c]]; reflexivity.
  - intros [[a|b] c]; reflexivity.
  - intros [[a|b] c]; reflexivity.
Defined.

(** The second is a statement about functions into a sum type. *)
Definition decompose_l {A B C} (f : C -> A + B) : Type
  := { c:C & is_inl (f c) }.

Definition decompose_r {A B C} (f : C -> A + B) : Type
  := { c:C & is_inr (f c) }.

Definition equiv_decompose {A B C} (f : C -> A + B)
: decompose_l f + decompose_r f <~> C.
Proof.
  simple refine (equiv_adjointify (sum_ind (fun _ => C) pr1 pr1) _ _ _).
  - intros c; destruct (is_inl_or_is_inr (f c));
    [ left | right ]; exists c; assumption.
  - intros c; destruct (is_inl_or_is_inr (f c)); reflexivity.
  - intros [[c l]|[c r]]; simpl; destruct (is_inl_or_is_inr (f c)).
    + apply ap, ap, path_ishprop.
    + elim (not_is_inl_and_inr' _ l i).
    + elim (not_is_inl_and_inr' _ i r).
    + apply ap, ap, path_ishprop.
Defined.

Definition is_inl_decompose_l {A B C} (f : C -> A + B)
           (z : decompose_l f)
: is_inl (f (equiv_decompose f (inl z)))
  := z.2.

Definition is_inr_decompose_r {A B C} (f : C -> A + B)
           (z : decompose_r f)
: is_inr (f (equiv_decompose f (inr z)))
  := z.2.

(** ** Indecomposability *)

(** A type is indecomposable if whenever it maps into a finite sum, it lands entirely in one of the summands.  It suffices to assert this for binary and nullary sums; in the latter case it reduces to nonemptiness. *)
Class Indecomposable (X : Type) :=
  { indecompose : forall A B (f : X -> A + B),
                    (forall x, is_inl (f x)) + (forall x, is_inr (f x))
  ; indecompose0 : ~~X }.

(** For instance, contractible types are indecomposable. *)
Global Instance indecomposable_contr `{Contr X} : Indecomposable X.
Proof.
  constructor.
  - intros A B f.
    destruct (is_inl_or_is_inr (f (center X))); [ left | right ]; intros x.
    all:refine (transport _ (ap f (contr x)) _); assumption.
  - intros nx; exact (nx (center X)).
Defined.

(** In particular, if an indecomposable type is equivalent to a sum type, then one summand is empty and it is equivalent to the other. *)
Definition equiv_indecomposable_sum {X A B} `{Indecomposable X}
           (f : X <~> A + B)
: ((X <~> A) * (Empty <~> B)) + ((X <~> B) * (Empty <~> A)).
Proof.
  destruct (indecompose A B f) as [i|i]; [ left | right ].
  1:pose (g := (f oE sum_empty_r X)).
  2:pose (g := (f oE sum_empty_l X)).
  2:apply (equiv_prod_symm _ _).
  all:refine (equiv_unfunctor_sum g _ _); try assumption; try intros [].
Defined.

(** Summing with an indecomposable type is injective on equivalence classes of types. *)
Definition equiv_unfunctor_sum_indecomposable_ll {A B B' : Type}
           `{Indecomposable A} (h : A + B <~> A + B')
: B <~> B'.
Proof.
  pose (f := equiv_decompose (h o inl)).
  pose (g := equiv_decompose (h o inr)).
  pose (k := (h oE (f +E g))).
  (** This looks messy, but it just amounts to swapping the middle two summands in [k]. *)
  pose (k' := k
                oE (equiv_sum_assoc _ _ _)
                oE ((equiv_sum_assoc _ _ _)^-1 +E 1)
                oE (1 +E (equiv_sum_symm _ _) +E 1)
                oE ((equiv_sum_assoc _ _ _) +E 1)
                oE (equiv_sum_assoc _ _ _)^-1).
  destruct (equiv_unfunctor_sum k'
       (fun x : decompose_l (h o inl) + decompose_l (h o inr) =>
        match x as x0 return (is_inl (k' (inl x0))) with
        | inl x0 => x0.2
        | inr x0 => x0.2
        end)
       (fun x : decompose_r (h o inl) + decompose_r (h o inr) =>
        match x as x0 return (is_inr (k' (inr x0))) with
        | inl x0 => x0.2
        | inr x0 => x0.2
        end)) as [s t]; clear k k'.
  refine (t oE (_ +E 1) oE g^-1).
  destruct (equiv_indecomposable_sum s^-1) as [[p q]|[p q]];
  destruct (equiv_indecomposable_sum f^-1) as [[u v]|[u v]].
  - refine (v oE q^-1).
  - elim (indecompose0 (v^-1 o p)).
  - refine (Empty_rec (indecompose0 _)); intros a.
    destruct (is_inl_or_is_inr (h (inl a))) as [l|r].
    * exact (q^-1 (a;l)).
    * exact (v^-1 (a;r)).
  - refine (u oE p^-1).
Defined.

Definition equiv_unfunctor_sum_contr_ll {A A' B B' : Type}
           `{Contr A} `{Contr A'}
           (h : A + B <~> A' + B')
: B <~> B'
  := equiv_unfunctor_sum_indecomposable_ll
       ((equiv_contr_contr +E 1) oE h).

(** ** Universal mapping properties *)

(** Ordinary universal mapping properties are expressed as equivalences of sets or spaces of functions.  In type theory, we can go beyond this and express an equivalence of types of *dependent* functions. *)

Definition sum_ind_uncurried {A B} (P : A + B -> Type)
           (fg : (forall a, P (inl a)) * (forall b, P (inr b)))
: forall s, P s
  := @sum_ind A B P (fst fg) (snd fg).

(* First the positive universal property.
   Doing this sort of thing without adjointifying will require very careful use of funext. *)
Global Instance isequiv_sum_ind `{Funext} `(P : A + B -> Type)
: IsEquiv (sum_ind_uncurried P) | 0.
Proof.
  apply (isequiv_adjointify
           (sum_ind_uncurried P)
           (fun f => (fun a => f (inl a), fun b => f (inr b))));
  repeat ((exact idpath)
            || intros []
            || intro
            || apply path_forall).
Defined.

Definition equiv_sum_ind `{Funext} `(P : A + B -> Type)
  := Build_Equiv _ _ _ (isequiv_sum_ind P).

(* The non-dependent version, which is a special case, is the sum-distributive equivalence. *)
Definition equiv_sum_distributive `{Funext} (A B C : Type)
: (A -> C) * (B -> C) <~> (A + B -> C)
  := equiv_sum_ind (fun _ => C).

(** ** Sums preserve most truncation *)

Global Instance istrunc_sum n' (n := n'.+2)
         `{IsTrunc n A, IsTrunc n B}
: IsTrunc n (A + B) | 100.
Proof.
  intros a b.
  eapply istrunc_equiv_istrunc;
    [ exact (equiv_path_sum _ _) | ].
  destruct a, b; simpl in *;
  try typeclasses eauto;
  intros [].
Defined.

Global Instance ishset_sum `{HA : IsHSet A, HB : IsHSet B} : IsHSet (A + B) | 100
  := @istrunc_sum (-2) A HA B HB.

(** Sums don't preserve hprops in general, but they do for disjoint sums. *)

Global Instance ishprop_sum A B `{IsHProp A} `{IsHProp B}
: (A -> B -> Empty) -> IsHProp (A + B).
Proof.
  intros H.
  apply hprop_allpath; intros [a1|b1] [a2|b2].
  - apply ap, path_ishprop.
  - case (H a1 b2).
  - case (H a2 b1).
  - apply ap, path_ishprop.
Defined.

(** ** Decidability *)

(** Sums preserve decidability *)
Global Instance decidable_sum {A B : Type}
       `{Decidable A} `{Decidable B}
: Decidable (A + B).
Proof.
  destruct (dec A) as [x1|y1].
  - exact (inl (inl x1)).
  - destruct (dec B) as [x2|y2].
    + exact (inl (inr x2)).
    + apply inr; intros z.
      destruct z as [x1|x2].
      * exact (y1 x1).
      * exact (y2 x2).
Defined.

(** Sums preserve decidable paths *)
Global Instance decidablepaths_sum {A B}
       `{DecidablePaths A} `{DecidablePaths B}
: DecidablePaths (A + B).
Proof.
  intros [a1|b1] [a2|b2].
  - destruct (dec_paths a1 a2) as [p|np].
    + exact (inl (ap inl p)).
    + apply inr; intros p.
      exact (np ((path_sum _ _)^-1 p)).
  - exact (inr (path_sum _ _)^-1).
  - exact (inr (path_sum _ _)^-1).
  - destruct (dec_paths b1 b2) as [p|np].
    + exact (inl (ap inr p)).
    + apply inr; intros p.
      exact (np ((path_sum _ _)^-1 p)).
Defined.

(** Because of [ishprop_sum], decidability of an hprop is again an hprop. *)
Global Instance ishprop_decidable_hprop `{Funext} A `{IsHProp A}
: IsHProp (Decidable A).
Proof.
  unfold Decidable; refine (ishprop_sum _ _ _).
  intros a na; exact (na a).
Defined.

(** ** Binary coproducts are equivalent to dependent sigmas where the first component is a bool. *)

Definition sig_of_sum A B (x : A + B)
: { b : Bool & if b then A else B }
  := (_;
      match
        x as s
        return
        (if match s with
              | inl _ => true
              | inr _ => false
            end then A else B)
      with
        | inl a => a
        | inr b => b
      end).

Definition sum_of_sig A B (x : { b : Bool & if b then A else B })
: A + B
  := match x with
       | (true; a) => inl a
       | (false; b) => inr b
     end.

Global Instance isequiv_sig_of_sum A B : IsEquiv (@sig_of_sum A B) | 0.
Proof.
  apply (isequiv_adjointify (@sig_of_sum A B)
                            (@sum_of_sig A B)).
  - intros [[] ?]; exact idpath.
  - intros []; exact idpath.
Defined.

Global Instance isequiv_sum_of_sig A B : IsEquiv (sum_of_sig A B)
  := isequiv_inverse (@sig_of_sum A B).

(** An alternative way of proving the truncation property of [sum]. *)
Definition trunc_sum' n A B `{IsTrunc n Bool, IsTrunc n A, IsTrunc n B}
: (IsTrunc n (A + B)).
Proof.
  eapply istrunc_equiv_istrunc; [ esplit;
                         exact (@isequiv_sum_of_sig _ _)
                       | ].
  typeclasses eauto.
Defined.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp
Require Import bigop ssralg matrix zmodp div.

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

Import GRing.Theory.
Local Open Scope nat_scope.
Local Open Scope ring_scope.

Section ExtraBigOp.

Lemma sumr_add : forall (R : ringType) m n (F : 'I_(m + n) -> R),
  \sum_(i < m + n) F i = \sum_(i < m) F (lshift _ i)
  + \sum_(i < n) F (rshift _ i).
Proof.
move=> R; elim=> [|m ihm] n F.
  rewrite !big_ord0 add0r; apply: congr_big=> // [[i hi]] _.
  by rewrite /rshift /=; congr F; apply: val_inj.
rewrite !big_ord_recl ihm -addrA.
congr (_ + _); first by congr F; apply: val_inj.
congr (_ + _); by apply: congr_big=> // i _ /=; congr F; apply: val_inj.
Qed.

Lemma mxtens_index_proof m n (ij : 'I_m * 'I_n) : ij.1 * n + ij.2 < m * n.
Proof.
case: m ij=> [[[] //]|] m ij; rewrite mulSn addnC -addSn leq_add //.
by rewrite leq_mul2r; case: n ij=> // n ij; rewrite leq_ord orbT.
Qed.

Definition mxtens_index m n ij := Ordinal (@mxtens_index_proof m n ij).

Lemma mxtens_index_proof1 m n (k : 'I_(m * n)) : k %/ n < m.
Proof. by move: m n k=> [_ [] //|m] [|n] k; rewrite ?divn0 // ltn_divLR. Qed.
Lemma mxtens_index_proof2 m n (k : 'I_(m * n)) : k %% n < n.
Proof. by rewrite ltn_mod; case: n k=> //; rewrite muln0=> [] []. Qed.

Definition mxtens_unindex m n k :=
  (Ordinal (@mxtens_index_proof1 m n k), Ordinal (@mxtens_index_proof2 m n k)).

Arguments mxtens_index {m n}.
Arguments mxtens_unindex {m n}.

Lemma mxtens_indexK m n : cancel (@mxtens_index m n) (@mxtens_unindex m n).
Proof.
case: m=> [[[] //]|m]; case: n=> [[_ [] //]|n].
move=> [i j]; congr (_, _); apply: val_inj=> /=.
  by rewrite divnMDl // divn_small ?addn0.
by rewrite modnMDl // modn_small.
Qed.

Lemma mxtens_unindexK m n : cancel (@mxtens_unindex m n) (@mxtens_index m n).
Proof.
case: m=> [[[] //]|m]. case: n=> [|n] k.
  by suff: False by []; move: k; rewrite muln0=> [] [].
by apply: val_inj=> /=; rewrite -divn_eq.
Qed.

Variant is_mxtens_index (m n : nat) : 'I_(m * n) -> Type :=
    IsMxtensIndex : forall (i : 'I_m) (j : 'I_n),
                   is_mxtens_index (mxtens_index (i, j)).

Lemma mxtens_indexP (m n : nat) (k : 'I_(m * n)) : is_mxtens_index k.
Proof. by rewrite -[k]mxtens_unindexK; constructor. Qed.

Lemma mulr_sum (R : ringType) m n (Fm : 'I_m -> R) (Fn : 'I_n -> R) :
  (\sum_(i < m) Fm i) * (\sum_(i < n) Fn i)
  = \sum_(i < m * n) ((Fm (mxtens_unindex i).1) * (Fn (mxtens_unindex i).2)).
Proof.
rewrite mulr_suml; transitivity (\sum_i (\sum_(j < n) Fm i * Fn j)).
  by apply: eq_big=> //= i _; rewrite -mulr_sumr.
rewrite pair_big; apply: reindex=> //=.
by exists mxtens_index=> i; rewrite (mxtens_indexK, mxtens_unindexK).
Qed.

End ExtraBigOp.

Section ExtraMx.

Lemma castmx_mul (R : ringType)
  (m m' n p p': nat) (em : m = m') (ep : p = p')
  (M : 'M[R]_(m, n)) (N : 'M[R]_(n, p)) :
  castmx (em, ep) (M *m N) = castmx (em, erefl _) M *m castmx (erefl _, ep) N.
Proof. by case: m' / em; case: p' / ep. Qed.

Lemma mulmx_cast (R : ringType)
  (m n n' p p' : nat) (en : n' = n) (ep : p' = p)
  (M : 'M[R]_(m, n)) (N : 'M[R]_(n', p')) :
  M *m (castmx (en, ep) N) =
  (castmx (erefl _, (esym en)) M) *m (castmx (erefl _, ep) N).
Proof. by case: n / en in M *; case: p / ep in N *. Qed.

Lemma castmx_row (R : Type) (m m' n1 n2 n1' n2' : nat)
  (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (eq_m : m = m') (A1 : 'M[R]_(m, n1)) (A2 : 'M_(m, n2)) :
  castmx (eq_m, eq_n12) (row_mx A1 A2) =
  row_mx (castmx (eq_m, eq_n1) A1) (castmx (eq_m, eq_n2) A2).
Proof.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by case: _ / eq_m; rewrite castmx_id.
Qed.

Lemma castmx_col (R : Type) (m m' n1 n2 n1' n2' : nat)
  (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (eq_m : m = m') (A1 : 'M[R]_(n1, m)) (A2 : 'M_(n2, m)) :
  castmx (eq_n12, eq_m) (col_mx A1 A2) =
  col_mx (castmx (eq_n1, eq_m) A1) (castmx (eq_n2, eq_m) A2).
Proof.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by case: _ / eq_m; rewrite castmx_id.
Qed.

Lemma castmx_block (R : Type) (m1 m1' m2 m2' n1 n2 n1' n2' : nat)
  (eq_m1 : m1 = m1') (eq_n1 : n1 = n1') (eq_m2 : m2 = m2') (eq_n2 : n2 = n2')
  (eq_m12 : (m1 + m2 = m1' + m2')%N) (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (ul : 'M[R]_(m1, n1)) (ur : 'M[R]_(m1, n2))
  (dl : 'M[R]_(m2, n1)) (dr : 'M[R]_(m2, n2)) :
  castmx (eq_m12, eq_n12) (block_mx ul ur dl dr) =
  block_mx (castmx (eq_m1, eq_n1) ul) (castmx (eq_m1, eq_n2) ur)
  (castmx (eq_m2, eq_n1) dl) (castmx (eq_m2, eq_n2) dr).
Proof.
case: _ / eq_m1 in eq_m12 *; case: _ / eq_m2 in eq_m12 *.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by rewrite !castmx_id.
Qed.

End ExtraMx.

Section MxTens.

Variable R : ringType.

Definition tensmx {m n p q : nat}
  (A : 'M_(m, n)) (B : 'M_(p, q)) : 'M[R]_(_,_) := nosimpl
  (\matrix_(i, j) (A (mxtens_unindex i).1 (mxtens_unindex j).1
                 * B (mxtens_unindex i).2 (mxtens_unindex j).2)).

Notation "A *t B" := (tensmx A B)
  (at level 40, left associativity, format "A  *t  B").

Lemma tensmxE {m n p q} (A : 'M_(m, n)) (B : 'M_(p, q)) i j k l :
  (A *t B) (mxtens_index (i, j)) (mxtens_index (k, l)) = A i k * B j l.
Proof. by rewrite !mxE !mxtens_indexK. Qed.

Lemma tens0mx {m n p q} (M : 'M[R]_(p,q)) : (0 : 'M_(m,n)) *t M = 0.
Proof. by apply/matrixP=> i j; rewrite !mxE mul0r. Qed.

Lemma tensmx0 {m n p q} (M : 'M[R]_(m,n)) : M *t (0 : 'M_(p,q)) = 0.
Proof. by apply/matrixP=> i j; rewrite !mxE mulr0. Qed.

Lemma tens_scalar_mx (m n : nat) (c : R) (M : 'M_(m,n)):
  c%:M *t M = castmx (esym (mul1n _), esym (mul1n _)) (c *: M).
Proof.
apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite tensmxE [i0]ord1 [j0]ord1 !castmxE !mxE /= mulr1n.
by congr (_ * M _ _); apply: val_inj.
Qed.

Lemma tens_scalar1mx (m n : nat) (M : 'M_(m,n)) :
  1 *t M = castmx (esym (mul1n _), esym (mul1n _)) M.
Proof. by rewrite tens_scalar_mx scale1r. Qed.

Lemma tens_scalarN1mx (m n : nat) (M : 'M_(m,n)) :
  (-1) *t M = castmx (esym (mul1n _), esym (mul1n _)) (-M).
Proof. by rewrite [-1]mx11_scalar /= tens_scalar_mx !mxE scaleNr scale1r. Qed.

Lemma trmx_tens {m n p q} (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (M *t N)^T = M^T *t N^T.
Proof. by apply/matrixP=> i j; rewrite !mxE. Qed.

Lemma tens_col_mx {m n p q} (r : 'rV[R]_n)
  (M :'M[R]_(m, n)) (N : 'M[R]_(p, q)) :
  (col_mx r M) *t N =
  castmx (esym (mulnDl _ _ _), erefl _) (col_mx (r *t N) (M *t N)).
Proof.
apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite !tensmxE castmxE /= cast_ord_id esymK !mxE /=.
case: splitP=> i0' /= hi0'; case: splitP=> k /= hk.
+ case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE.
  move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1].
  by congr (r _ _ * N _ _); apply: val_inj; rewrite /= -?h0 ?h1.
+ move: hk (ltn_ord i1); rewrite hi0'.
  by rewrite [i0']ord1 mul0n mul1n add0n ltnNge=> ->; rewrite leq_addr.
+ move: (ltn_ord k); rewrite -hk hi0' ltnNge {1}mul1n.
  by rewrite mulnDl {1}mul1n -addnA leq_addr.
case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE.
rewrite hi0' mulnDl -addnA=> /addnI.
 move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1].
by congr (M _ _ * N _ _); apply: val_inj; rewrite /= -?h0 ?h1.
Qed.

Lemma tens_row_mx {m n p q} (r : 'cV[R]_m) (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (row_mx r M) *t N =
  castmx (erefl _, esym (mulnDl _ _ _)) (row_mx (r *t N) (M *t N)).
Proof.
rewrite -[_ *t _]trmxK trmx_tens tr_row_mx tens_col_mx.
apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP.
by rewrite trmx_cast castmx_comp castmx_id tr_col_mx -!trmx_tens !trmxK.
Qed.

Lemma tens_block_mx {m n p q}
  (ul : 'M[R]_1) (ur : 'rV[R]_n) (dl : 'cV[R]_m)
  (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (block_mx ul ur dl M) *t N =
  castmx (esym (mulnDl _ _ _), esym (mulnDl _ _ _))
  (block_mx (ul *t N) (ur *t N) (dl *t N) (M *t N)).
Proof.
rewrite !block_mxEv tens_col_mx !tens_row_mx -!cast_col_mx castmx_comp.
by congr (castmx (_,_)); apply nat_irrelevance.
Qed.

Fixpoint ntensmx_rec {m n} (A : 'M_(m,n)) k : 'M_(m ^ k.+1,n ^ k.+1) :=
  if k is k'.+1 then (A *t (ntensmx_rec A k')) else A.

Definition ntensmx {m n} (A : 'M_(m, n)) k := nosimpl
  (if k is k'.+1 return 'M[R]_(m ^ k,n ^ k) then ntensmx_rec A k' else 1).

Notation "A ^t k" := (ntensmx A k)
  (at level 39, left associativity, format "A  ^t  k").

Lemma ntensmx0 : forall {m n} (A : 'M_(m,n)) , A ^t 0 = 1.
Proof. by []. Qed.

Lemma ntensmx1 : forall {m n} (A : 'M_(m,n)) , A ^t 1 = A.
Proof. by []. Qed.

Lemma ntensmx2 : forall {m n} (A : 'M_(m,n)) , A ^t 2 = A *t A.
Proof. by []. Qed.

Lemma ntensmxSS : forall {m n} (A : 'M_(m,n)) k, A ^t k.+2 = A *t A ^t k.+1.
Proof. by []. Qed.

Definition ntensmxS := (@ntensmx1, @ntensmx2, @ntensmxSS).

End MxTens.

Notation "A *t B" := (tensmx A B)
  (at level 40, left associativity, format "A  *t  B").

Notation "A ^t k" := (ntensmx A k)
  (at level 39, left associativity, format "A  ^t  k").

Section MapMx.
Variables (aR rR : ringType).
Hypothesis f : {rmorphism aR -> rR}.
Local Notation "A ^f" := (map_mx f A) : ring_scope.

Variables m n p q: nat.
Implicit Type A : 'M[aR]_(m, n).
Implicit Type B : 'M[aR]_(p, q).

Lemma map_mxT A B : (A *t B)^f = A^f *t B^f :> 'M_(m*p, n*q).
Proof. by apply/matrixP=> i j; rewrite !mxE /= rmorphM. Qed.

End MapMx.

Section Misc.

Lemma tensmx_mul (R : comRingType) m n p q r s
  (A : 'M[R]_(m,n)) (B : 'M[R]_(p,q)) (C : 'M[R]_(n, r)) (D : 'M[R]_(q, s)) :
  (A *t B) *m (C *t D) = (A *m C) *t (B *m D).
Proof.
apply/matrixP=> /= i j.
case (mxtens_indexP i)=> [im ip] {i}; case (mxtens_indexP j)=> [jr js] {j}.
rewrite !mxE !mxtens_indexK mulr_sum; apply: congr_big=> // k _.
by rewrite !mxE !mxtens_indexK mulrCA !mulrA [C _ _ * A _ _]mulrC.
Qed.

(* Todo : move to div ? *)
Lemma eq_addl_mul q q' m m' d : m < d -> m' < d ->
  (q * d + m == q' * d  + m')%N = ((q, m) == (q', m')).
Proof.
move=> lt_md lt_m'd; apply/eqP/eqP; last by move=> [-> ->].
by move=> /(f_equal (edivn^~ d)); rewrite !edivn_eq.
Qed.

Lemma tensmx_unit (R : fieldType) m n (A : 'M[R]_m%N) (B : 'M[R]_n%N) :
  m != 0%N -> n != 0%N -> A \in unitmx -> B \in unitmx -> (A *t B) \in unitmx.
Proof.
move: m n A B => [|m] [|n] // A B _ _ uA uB.
suff : (A^-1 *t B^-1) *m (A *t B) = 1 by case/mulmx1_unit.
rewrite tensmx_mul !mulVmx //; apply/matrixP=> /= i j.
rewrite !mxE /=; symmetry; rewrite -natrM -!val_eqE /=.
rewrite {1}(divn_eq i n.+1) {1}(divn_eq j n.+1).
by rewrite eq_addl_mul ?ltn_mod // xpair_eqE mulnb.
Qed.

Lemma tens_mx_scalar : forall (R : comRingType)
  (m n : nat) (c : R) (M : 'M[R]_(m,n)),
  M *t c%:M = castmx (esym (muln1 _), esym (muln1 _)) (c *: M).
Proof.
move=> R0 m n c M; apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite tensmxE [i1]ord1 [j1]ord1 !castmxE !mxE /= mulr1n mulrC.
by congr (_ * M _ _); apply: val_inj=> /=; rewrite muln1 addn0.
Qed.

Lemma tensmx_decr : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n),
  M *t N = (M *t 1%:M) *m (1%:M *t N).
Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed.

Lemma tensmx_decl : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n),
  M *t N = (1%:M *t N) *m (M *t 1%:M).
Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed.

End Misc.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Bool Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import subcode sss.

From Undecidability.TM
  Require Import SBTM.

From Undecidability.TM
  Require Export PCTM.

Import PCTMNotations SBTMNotations ListNotations.

Set Implicit Arguments.

#[local] Notation "i // s -1> t" := (pctm_sss i s t).
#[local] Notation "P // s -[ k ]-> t" := (sss_steps pctm_sss P k s t).
#[local] Notation "P // s ->> t" := (sss_compute pctm_sss P s t).
#[local] Notation "P // s -+> t" := (sss_progress pctm_sss P s t).

Section PC_based_Turing_Machine.

  Implicit Type P : (nat*list pctm_instr)%type.

  Tactic Notation "mydiscr" :=
    match goal with H: ?x = _, G : ?x = _ |- _ => rewrite H in G; discriminate end.

  Tactic Notation "myinj" :=
    match goal with H: ?x = _, G : ?x = _ |- _ => rewrite H in G; inversion G; subst; auto end.

  (* pctm_sss is a functional relation *)

  Fact pctm_sss_fun ρ s t1 t2 : ρ // s -1> t1 -> ρ // s -1> t2 -> t1 = t2.
  Proof. intros []; subst; inversion 1; subst; auto; try mydiscr; myinj. Qed.

  (* pctm_sss is an informativelly total relation *)

  Fact pctm_sss_total ρ s : { s' | ρ // s -1> s' }.
  Proof.
    destruct s as (i,t).
    destruct ρ as [ d | b | j p ].
    + exists (1+i,mv d t); constructor.
    + destruct t as ((l,x),r).
      exists (1+i,(l,b,r)); constructor.
    + destruct t as ((l,b),r).
      exists (if b then j else p,(l,b,r)); constructor.
  Qed.

  Fact pctm_sss_total' ρ s : exists s', ρ // s -1> s'.
  Proof. destruct (pctm_sss_total ρ s); firstorder. Qed.

  Tactic Notation "solve" "progress" :=
    let H := fresh
    in intros H;
       apply sss_progress_compute_trans;
       apply subcode_sss_progress with (1 := H);
       exists 1; split; auto; apply sss_steps_1;
       apply in_sss_step with (l := nil); [ simpl; lia | ];
       try (constructor; auto).

  Fact pctm_progress_MV P i d t st :
         (i,[MV d]) <sc P
      -> P // (1+i,mv d t) ->> st
      -> P // (i,t) -+> st.
  Proof. solve progress. Qed.

  Fact pctm_progress_WR P i b t st :
         (i,[WR b]) <sc P
      -> P // (1+i,wr t b) ->> st
      -> P // (i,t) -+> st.
  Proof. solve progress. Qed.

  Fact pctm_progress_BR P i j p t st :
         (i,[BR j p]) <sc P
      -> P // (if rd t then j else p,t) ->> st
      -> P // (i,t) -+> st.
  Proof. solve progress. Qed.

  Hint Resolve pctm_progress_MV
               pctm_progress_WR
               pctm_progress_BR : core.

  Tactic Notation "solve" "compute" :=
    intros; apply sss_progress_compute; eauto.

  Fact pctm_compute_MV P i d t st :
         (i,[MV d]) <sc P
      -> P // (1+i,mv d t) ->> st
      -> P // (i,t) ->> st.
  Proof. solve compute. Qed.

  Fact pctm_compute_WR P i b t st :
         (i,[WR b]) <sc P
      -> P // (1+i,wr t b) ->> st
      -> P // (i,t) ->> st.
  Proof. solve compute. Qed.

  Fact pctm_compute_BR P i j p t st :
         (i,[BR j p]) <sc P
      -> P // (if rd t then j else p,t) ->> st
      -> P // (i,t) ->> st.
  Proof. solve compute. Qed.

End PC_based_Turing_Machine.

Tactic Notation "pctm" "sss" "MV" "with" uconstr(a) :=
  match goal with
    | |- _ // _ -+> _ => apply pctm_progress_MV with (d := a)
    | |- _ // _ ->> _ => apply pctm_compute_MV with (d := a)
  end; auto.

Tactic Notation "pctm" "sss" "WR" "with" uconstr(a) :=
  match goal with
    | |- _ // _ -+> _ => apply pctm_progress_WR with (b := a)
    | |- _ // _ ->> _ => apply pctm_compute_WR with (b := a)
  end; auto.

Tactic Notation "pctm" "sss" "BR" "with" uconstr(a) uconstr(b) :=
  match goal with
    | |- _ // _ -+> _ => apply pctm_progress_BR with (j := a) (p := b)
    | |- _ // _ ->> _ => apply pctm_compute_BR with (j := a) (p := b)
  end; auto.

Tactic Notation "pctm" "sss" "stop" := exists 0; apply sss_steps_0; auto.

Section extra.

  Implicit Type P : (nat*list pctm_instr)%type.

  Fact pctm_progress_JMP P i j t st :
        (i,[BR j j]) <sc P
      -> P // (j,t) ->> st
      -> P // (i,t) -+> st.
  Proof.
    intros.
    pctm sss BR with j j.
    destruct (rd t); auto.
  Qed.

  Fact pctm_compute_JMP P i j t st :
        (i,[BR j j]) <sc P
      -> P // (j,t) ->> st
      -> P // (i,t) ->> st.
  Proof. intros; eapply sss_progress_compute, pctm_progress_JMP; eauto. Qed.

End extra.

Tactic Notation "pctm" "sss" "JMP" "with" uconstr(a) :=
  match goal with
    | |- _ // _ -+> _ => apply pctm_progress_JMP with (j := a)
    | |- _ // _ ->> _ => apply pctm_compute_JMP with (j := a)
  end; auto.