(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library proofs that uniqueness of normal forms (UN) is not implied
   by weak orthogonality (WO) by counterexample. *)

Require Import Rewriting.
Require Import Equality.

Set Implicit Arguments.

(** We construct the weakly orthogonal TRS with rules
    - PS : P(S(x)) -> x
    - SP : S(P(x)) -> x
    and show it is a counterexample to UN-inf.

    J. Endrullis, C. Grabmayer, D. Hendriks, J.W. Klop and V. van Oostrom.
    Unique Normal Forms in Infinitary Weakly Orthogonal Rewriting.
    Rewriting Techniques and Applications, 2010.

    Because we have [S] as constructor for [nat], we rename the function
    symbols to D and U ('up' and 'down').

    Let psi = U D D U U U D D D D... We show that
    - this TRS is weakly orthogonal
    - psi rewrites to DDD...
    - psi rewrites to UUU...
    - DDD... is a normal form
    - UUU... is a normal form
    - DDD... and UUU... are not bisimilar

    Together this gives a counterexample to (WO => UN). *)

(** * Signature

   We have two unary function symbols [D] and [U]. *)

Inductive symbol : Set := D | U.

Definition beq_symb (f g : symbol) : bool :=
  match f, g with
  | D, D => true
  | U, U => true
  | _, _ => false
end.

Lemma beq_symb_ok : forall f g, beq_symb f g = true <-> f = g.
Proof.
(* This should work for any finite inductive symbol type *)
intros f g.
split; intro H.
(* beq_symb f g = true -> f = g *)
  destruct f; destruct g; simpl; (reflexivity || discriminate).
(* f = g ->  beq_symb f g = true *)
  subst g; destruct f; simpl; reflexivity.
Qed.

Definition arity (f : symbol) : nat :=
  match f with
  | D => 1
  | U => 1
  end.

(** * Variables

   We only need one variable that is used in both rewrite rules. *)

Definition variable : Set := unit.

Fixpoint beq_var (x y : variable) : bool := true.

Lemma beq_var_ok : forall x y, beq_var x y = true <-> x = y.
Proof.
intros [] []; split; reflexivity.
Qed.

(** * Terms

   Terms over the given signature and variable. *)

Definition F : signature := Signature arity beq_symb_ok.
Definition X : variables := Variables beq_var_ok.

Notation term := (term F X).
Notation fterm := (finite_term F X).
Notation terms := (vector term).

(** We define notational shortcuts for constructing terms:
   - variable [x] by [x!]
   - function application of [f] to [a] by [f @ a]
   - function application of [f] to [a] by [f @@ a] for finite terms *)

Notation "x !" := (@FVar F X x) (at level 75).

Notation "f @ a" := (@Fun F X f (vcons a (vnil term))) (right associativity, at level 75).
Notation "f @@ a" := (@FFun F X f (vcons a (vnil fterm))) (right associativity, at level 75).

(** UUU... *)
CoFixpoint repeat_U : term :=
  U @ repeat_U.

(** DDD... *)
CoFixpoint repeat_D : term :=
  D @ repeat_D.

(** U^n t *)
Fixpoint Unt (n : nat) t :=
  match n with
  | O   => t
  | S n => U @ (Unt n t)
  end.

(** D^n t *)
Fixpoint Dnt (n : nat) t :=
  match n with
  | O   => t
  | S n => D @ (Dnt n t)
  end.

(** U^2n t *)
Fixpoint U2nt (n : nat) t :=
  match n with
  | O   => t
  | S n => U @ U @ (U2nt n t)
  end.

(** D^2n t *)
Fixpoint D2nt (n : nat) t :=
  match n with
  | O   => t
  | S n => D @ D @ (D2nt n t)
  end.

(** D^n U^n t *)
Definition DnUnt n t : term :=
  Dnt n (Unt n t).

(** U^n D^n t *)
Definition UnDnt n t : term :=
  Unt n (Dnt n t).

(** D^2n U^2n t *)
Definition D2nU2nt n t : term :=
  D2nt n (U2nt n t).

(** U^2n D^2n t *)
Definition U2nD2nt n t : term :=
  U2nt n (D2nt n t).

(** We now define the term

     [psi] = D U^2 D^3 U^4 ...

   via an auxiliary parameterised term [psi'].

   We would like to define psi' like this
[[
     CoFixpoint psi' n : term :=
       Unt n (Dnt (S n) (psi' (S (S n)))).
]]
   but unfortunately this is not in guarded form. We therefore turn to a
   more complex definition with anonymous cofixpoints. *)

(** [psi' n] = D^n U^Sn D^SSn U^SSSn ... *)
CoFixpoint psi' n : term :=
  (cofix D2nDt (d : nat) :=
    match d with
    | O   => D @ (cofix U2nt (u : nat) :=
               match u with
               | O   => psi' (S n)
               | S u => U @ U @ (U2nt u)
               end) (S n)
    | S d => D @ D @ (D2nDt d)
    end) n.

(* [psi] = D U^2 D^3 U^4 ... *)
Definition psi := psi' 0.

(** Some useful lemmas on bisimilarity and equality of common terms follow. *)

Lemma term_bis_U :
  forall t s,
    t [~] s -> (U @ t) [~] (U @ s).
Proof.
intros t s H.
constructor.
intro i; dependent destruction i; [idtac | inversion i].
assumption.
Qed.

Lemma term_bis_D :
  forall t s,
    t [~] s -> (D @ t) [~] (D @ s).
Proof.
intros t s H.
constructor.
intro i; dependent destruction i; [idtac | inversion i].
assumption.
Qed.

Lemma term_eq_up_to_n_Unt_repeat_U :
  forall n t,
    term_eq_up_to n (Unt n t) repeat_U.
Proof.
induction n as [| n IH]; simpl; intro t.
constructor.
rewrite (peek_eq repeat_U); simpl.
constructor.
intro i.
dependent destruction i.
apply IH.
dependent destruction i.
Qed.

Lemma term_eq_up_to_n_Dnt_repeat_D :
  forall n t,
    term_eq_up_to n (Dnt n t) repeat_D.
Proof.
induction n as [| n IH]; simpl; intro t.
constructor.
rewrite (peek_eq repeat_D); simpl.
constructor.
intro i.
dependent destruction i.
apply IH.
dependent destruction i.
Qed.

Lemma term_bis_Unt :
  forall n t s,
    t [~] s -> Unt n t [~] Unt n s.
Proof.
induction n; intros t s H; simpl.
assumption.
apply term_bis_U.
apply IHn.
assumption.
Qed.

Lemma term_bis_Dnt :
  forall n t s,
    t [~] s -> Dnt n t [~] Dnt n s.
Proof.
induction n; intros t s H; simpl.
assumption.
apply term_bis_D.
apply IHn.
assumption.
Qed.

Lemma UUnt_eq_UnUt :
  forall n t,
    (U @ Unt n t) = Unt n (U @ t).
induction n; intro t.
reflexivity.
simpl.
rewrite <- IHn.
reflexivity.
Qed.

Lemma DDnt_eq_DnDt :
  forall n t,
    (D @ Dnt n t) = Dnt n (D @ t).
induction n; intro t.
reflexivity.
simpl.
rewrite <- IHn.
reflexivity.
Qed.

Lemma UU2nt_eq_U2nUt :
  forall n t,
    (U @ U2nt n t) = U2nt n (U @ t).
induction n; intro t.
reflexivity.
simpl.
rewrite <- IHn.
reflexivity.
Qed.

Lemma DD2nt_eq_D2nDt :
  forall n t,
    (D @ D2nt n t) = D2nt n (D @ t).
induction n; intro t.
reflexivity.
simpl.
rewrite <- IHn.
reflexivity.
Qed.

Lemma DSnUSnt_eq_DDnUnUt :
  forall n t,
    DnUnt (S n) t = (D @ (DnUnt n (U @ t))).
Proof.
intros n t.
unfold DnUnt.
simpl.
rewrite UUnt_eq_UnUt.
reflexivity.
Qed.

Lemma USnDSnt_eq_UUnDnDt :
  forall n t,
    UnDnt (S n) t = (U @ (UnDnt n (D @ t))).
Proof.
intros n t.
unfold UnDnt.
simpl.
rewrite DDnt_eq_DnDt.
reflexivity.
Qed.

Lemma D2SnU2Snt_eq_DDD2nU2nUUt :
  forall n t,
    D2nU2nt (S n) t = (D @ D @ (D2nU2nt n (U @ U @ t))).
Proof.
intros n t.
unfold D2nU2nt.
simpl.
rewrite UU2nt_eq_U2nUt.
rewrite UU2nt_eq_U2nUt.
reflexivity.
Qed.

Lemma U2SnD2Snt_eq_UUU2nD2nDDt :
  forall n t,
    U2nD2nt (S n) t = (U @ U @ (U2nD2nt n (D @ D @ t))).
Proof.
intros n t.
unfold U2nD2nt.
simpl.
rewrite DD2nt_eq_D2nDt.
rewrite DD2nt_eq_D2nDt.
reflexivity.
Qed.

Lemma D2nU2nt_eq_D2nU2nt :
  forall n t,
    D2nU2nt n t = DnUnt (2 * n) t.
Proof.
induction n; intro t; simpl.
unfold D2nU2nt, D2nt, U2nt, DnUnt, Dnt, Unt.
reflexivity.
rewrite D2SnU2Snt_eq_DDD2nU2nUUt.
rewrite DSnUSnt_eq_DDnUnUt.
rewrite IHn with (U @ U @ t).
simpl.
rewrite (eq_sym (plus_n_Sm n (n + 0))).
rewrite DSnUSnt_eq_DDnUnUt.
reflexivity.
Qed.

(** Some useful (but ugly) lemmas on bisimilarity and equality of psi and
   (partial) unfoldings follow. *)

Lemma UU2nt_eq_U2nUt_unfolded :
  forall n t,
    (U @ (cofix U2nt (u : nat) : term :=
            match u with
            | 0 => t
            | S u0 => U @ U @ U2nt u0
            end) n)
    =
    (cofix U2nt (u : nat) : term :=
       match u with
       | 0 => U @ t
       | S u0 => U @ U @ U2nt u0
       end) n.
Proof.
induction n; intro t.
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
        match u with
        | 0 => t
        | S u0 => U @ U @ U2nt u0
        end) 0)).
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
      match u with
      | 0 => U @ t
      | S u0 => U @ U @ U2nt u0
      end) 0)).
simpl.
destruct t; reflexivity.
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
       match u with
       | 0 => t
       | S u0 => U @ U @ U2nt u0
       end) (S n))).
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
      match u with
      | 0 => U @ t
      | S u0 => U @ U @ U2nt u0
      end) (S n))).
simpl.
rewrite IHn with t.
reflexivity.
Qed.

Lemma psin_eq_DD2nU2nUUpsiSn :
  forall n,
    psi' n = (D @ (D2nU2nt n (U @ U @ (psi' (S n))))).
Proof.
intro n.
rewrite (peek_eq (psi' n)).
simpl.
generalize (psi' (S n)).
induction n; intro t.
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
       match u with
       | 0 => t
       | S u0 => U @ U @ U2nt u0
       end) 1)).
unfold D2nU2nt.
simpl.
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
       match u with
       | 0 => t
       | S u0 => U @ U @ U2nt u0
       end) 0)).
simpl.
destruct t; reflexivity.
rewrite (peek_eq ((cofix U2nt (u : nat) : term :=
                 match u with
                 | 0 => t
                 | S u0 => U @ U @ U2nt u0
                 end) (S (S n)))).
rewrite D2SnU2Snt_eq_DDD2nU2nUUt.
simpl.
rewrite UU2nt_eq_U2nUt_unfolded with (S n) t.
rewrite UU2nt_eq_U2nUt_unfolded with (S n) (U @ t).
rewrite (peek_eq ((cofix D2nDt (d : nat) : term :=
       match d with
       | 0 =>
           D @
           (cofix U2nt (u : nat) : term :=
              match u with
              | 0 => U @ U @ t
              | S u0 => U @ U @ U2nt u0
              end) (S n)
       | S d0 => D @ D @ D2nDt d0
       end) n)).
simpl.
rewrite IHn with (U @ U @ t).
reflexivity.
Qed.

Lemma psin_eq_DS2nUS2nUpsiSn :
  forall n,
    psi' n = DnUnt (S (2 * n)) (U @ (psi' (S n))).
Proof.
intro n.
rewrite psin_eq_DD2nU2nUUpsiSn.
rewrite D2nU2nt_eq_D2nU2nt.
rewrite DSnUSnt_eq_DDnUnUt.
reflexivity.
Qed.

(** * Contexts

   Contexts over the given signature and variable. *)

Notation context := (context F X).

(** Notational shortcut for function application in contexts. *)
Notation "f @@@ a" := (@CFun F X f 0 0 (@refl_equal nat (arity f)) (vnil term) a (vnil term)) (right associativity, at level 75).

(** D^n c *)
Fixpoint Dnc n c : context :=
  match n with
  | O   => c
  | S n => D @@@ (Dnc n c)
  end.

(** U^n c *)
Fixpoint Unc n c : context :=
  match n with
  | O   => c
  | S n => U @@@ (Unc n c)
  end.

(** We prove some lemmas about filling contexts. *)

Lemma fill_Dnc_t :
  forall n c t,
    fill (Dnc n c) t = Dnt n (fill c t).
Proof.
induction n.
reflexivity.
intros c t.
simpl.
rewrite IHn.
reflexivity.
Qed.

Lemma fill_Unc_t :
  forall n c t,
    fill (Unc n c) t = Unt n (fill c t).
Proof.
induction n.
reflexivity.
intros c t.
simpl.
rewrite IHn.
reflexivity.
Qed.

Lemma fill_DnHole_t :
  forall n t,
    fill (Dnc n Hole) t = Dnt n t.
Proof.
intros n t.
apply fill_Dnc_t.
Qed.

Lemma fill_UnHole_t :
  forall n t,
    fill (Unc n Hole) t = Unt n t.
Proof.
intros n t.
apply fill_Unc_t.
Qed.

Lemma fill_DmUnc_t :
  forall m n c t,
    fill (Dnc m (Unc n c)) t = Dnt m (Unt n (fill c t)).
Proof.
intros m n c t.
rewrite fill_Dnc_t.
rewrite fill_Unc_t.
reflexivity.
Qed.

Lemma fill_UmDnc_t :
  forall m n c t,
    fill (Unc m (Dnc n c)) t = Unt m (Dnt n (fill c t)).
Proof.
intros m n c t.
rewrite fill_Unc_t.
rewrite fill_Dnc_t.
reflexivity.
Qed.

Lemma fill_DmUnHole_t :
  forall m n t,
    fill (Dnc m (Unc n Hole)) t = Dnt m (Unt n t).
Proof.
intros m n t.
apply fill_DmUnc_t.
Qed.

Lemma fill_UmDnHole_t :
  forall m n t,
    fill (Unc m (Dnc n Hole)) t = Unt m (Dnt n t).
Proof.
intros m n t.
apply fill_UmDnc_t.
Qed.

(** * Rewriting

   We construct the rewrite rules for the TRS and show it is weakly
   orthogonal. We also show that UUU... and DDD... are normal forms. *)

Notation trs := (trs F X).

(** We use this variable in the rewrite rules *)
Definition varx : X := tt.

(** Rule [DU] : DUx -> x *)

Definition DU_l : fterm := D @@ U @@ varx!.
Definition DU_r : fterm := varx!.

Lemma wf_DU :
  is_var DU_l = false /\
  incl (vars DU_r) (vars DU_l).
Proof.
split; simpl.
reflexivity.
intros a H.
assumption.
Qed.

Definition DU : rule := Rule DU_l DU_r wf_DU.

(** Rule [UD] : UDx -> x *)

Definition UD_l : fterm := U @@ D @@ varx!.
Definition UD_r : fterm := varx!.

Lemma wf_UD :
  is_var UD_l = false /\
  incl (vars UD_r) (vars UD_l).
Proof.
split; simpl.
reflexivity.
intros a H.
assumption.
Qed.

Definition UD : rule := Rule UD_l UD_r wf_UD.

(** The TRS [UD_trs] as a list of its rules. *)

Definition UD_trs : trs := DU :: UD :: nil.

(** [UD_trs] is trivialy left-linear. *)
Lemma left_linear_UD :
  trs_left_linear UD_trs.
Proof.
constructor; [| constructor];
  unfold left_linear; unfold linear; simpl;
    constructor.
intro; assumption.
constructor.
intro; assumption.
constructor.
Qed.

(** All critical pairs in [UD_trs] are trivial. *)
Lemma critical_pairs_trivial_UD :
  forall t1 t2,
    critical_pair UD_trs t1 t2 ->
    t1 [~] t2.
Proof.
intros t1 t2 H.
unfold critical_pair in H.
destruct H as [r1 [r2 [[| [| a] [| [| b] [| c p]]] [sigma [tau [[Hr1 | [Hr1 | []]] [[Hr2 | [Hr2 | []]] [T H]]]]]]]];
rewrite <- Hr1 in * |-;
rewrite <- Hr2 in * |-;
clear r1 r2 Hr1 Hr2;
try (contradict T; auto; fail);
clear T;
try (contradict H; fail); simpl in H;
destruct H as [V [H [H1 H2]]];
try (contradict V; fail);
apply (term_bis_trans H1); apply term_bis_symm; apply (term_bis_trans H2);
clear H1 H2;
dependent destruction H; specialize H with (First (n := 0)); unfold vmap in H; simpl in H;
dependent destruction H; specialize H with (First (n := 0)); unfold vmap in H; simpl in H;
clear V.

rewrite <- x.
constructor.
intro i.
dependent destruction i.
unfold vcast.
generalize (lt_plus_minus_r (Gt.gt_le_S 0 1 (Lt.lt_0_Sn 0))).
intro e.
dependent destruction e.
generalize (lt_plus_minus_r (Lt.lt_le_S 0 1 (Lt.lt_0_Sn 0))).
intro e.
dependent destruction e.
assumption.
inversion i.

rewrite <- x.
constructor.
intro i.
dependent destruction i.
unfold vcast.
generalize (lt_plus_minus_r (Gt.gt_le_S 0 1 (Lt.lt_0_Sn 0))).
intro e.
dependent destruction e.
generalize (lt_plus_minus_r (Lt.lt_le_S 0 1 (Lt.lt_0_Sn 0))).
intro e.
dependent destruction e.
assumption.
inversion i.
Qed.

Lemma weakly_orthogonal_UD :
  weakly_orthogonal UD_trs.
Proof.
split.
exact left_linear_UD.
exact critical_pairs_trivial_UD.
Qed.

(** DDD... is a normal form. *)
Lemma normal_form_repeat_D :
  normal_form UD_trs repeat_D.
Proof.
(** TODO: a lot of this proof is a mess, cleanup.
   Also, I expect that this could be generalized and shortened quite a bit
   by using pos_eq. *)
intros [c [r [u [H1 H2]]]].
destruct H1 as [H1 | [H1 | []]].
rewrite <- H1 in *|-.
clear H1.
assert (H := (term_bis_implies_term_eq H2) (S (S (hole_depth c)))).
rewrite (peek_eq repeat_D) in H.
dependent destruction H.
assert (H' := H First).
rewrite (peek_eq repeat_D) in H'.
dependent destruction H'.
assert (H' := H0 First).
simpl in H'.

(* idea, make [=]1 from x0 *)
assert (y0 : term_eq_up_to 1 (@Fun F X D v) (fill c (@Fun F X D (vmap (substitute u) (vcons (U @@ varx!) (vnil fterm)))))).
(*assert (y0 : @Fun F X D v [=] fill c (@Fun F X D (vmap (substitute u) (vcons (U @@ 1 !) (vnil fterm))))).*)
rewrite x0.
apply term_eq_up_to_refl.
clear x0.

induction c.

assert (H3 := (term_bis_implies_term_eq H2) 2).
rewrite (peek_eq repeat_D) in H3.
dependent destruction H3.
assert (H3 := H1 First).
rewrite (peek_eq repeat_D) in H3.
dependent destruction H3.

rewrite (peek_eq repeat_D) in H2.
(*intro x0.*)
assert (d : f = D).
(*assert (y1 := y0 1).*)
inversion_clear y0.
reflexivity.

(*injection x0.
intros _ d.*)
revert e H2 H y0 H0 H'.
dependent rewrite d.
intro e.
assert (ij : i = 0 /\ j = 0).
destruct i as [| [| i]]; auto; discriminate e.
revert e v1 v2.
rewrite (proj1 ij).
rewrite (proj2 ij).
intros e v1 v2 H2 H y0 H0 H'.
clear f i j d ij.
apply IHc; clear IHc.

(* this part is quite ugly *)
apply term_eq_implies_term_bis.
intro n.
assert (H2' : term_eq_up_to (S n) (@Fun F X D (vcons (fill c (substitute u (lhs DU))) v2)) (D @ repeat_D)).
assert (jaja : fill (@CFun F X D 0 0 e v1 c v2) (substitute u (lhs DU)) = @Fun F X D (vcons (fill c (substitute u (lhs DU))) v2)).
dependent destruction e.
reflexivity.
rewrite jaja in H2.
exact ((term_bis_implies_term_eq H2) (S n)).
apply (@teut_fun_inv F X n D (vcons (fill c (substitute u (lhs DU))) v2) (vcons repeat_D (vnil term)) H2' First).
intro i.
apply term_eq_up_to_weaken.
apply H.
intro i.
dependent destruction i.
apply term_eq_up_to_weaken.
assumption.
dependent destruction i.
apply term_eq_up_to_weaken.
assumption.

clear v0 x H y0 H0 H'.
destruct c.
constructor.
constructor.
simpl.
simpl in H2.
dependent destruction H2.
assert (H3 := H First).
simpl in H3.
clear H.
rewrite (peek_eq repeat_D) in H3.
dependent destruction H3.
revert x.
dependent destruction e.
intro y.
simpl in y.
injection y.
intros _ d.
clear y x H v1 v2 v4.
revert e0.
rewrite <- d.
intro e.
constructor.
constructor.

(** Almost the same argument follows for [r=UD] instead of [r=DU]. *)

rewrite <- H1 in *|-.
clear H1.
assert (H := (term_bis_implies_term_eq H2) (S (hole_depth c))).
rewrite (peek_eq repeat_D) in H.
dependent destruction H.
assert (H' := H First).
simpl in H'.
clear x.

induction c.

rewrite (peek_eq repeat_D) in H2.
inversion_clear H2.

rewrite (peek_eq repeat_D) in H2.
(*intro x0.*)
assert (d : f = D).
inversion_clear H2.
reflexivity.

revert e H2 H H'.
dependent rewrite d.
intro e.
assert (ij : i = 0 /\ j = 0).
destruct i as [| [| i]]; auto; discriminate e.
revert e v0 v1.
rewrite (proj1 ij).
rewrite (proj2 ij).
intros e v1 v2 H2 H H'.
clear f i j d ij.
apply IHc; clear IHc.

(* this part is quite ugly *)
apply term_eq_implies_term_bis.
intro n.
assert (H2' : term_eq_up_to (S n) (@Fun F X D (vcons (fill c (substitute u (lhs UD))) v2)) (D @ repeat_D)).
assert (jaja : fill (@CFun F X D 0 0 e v1 c v2) (substitute u (lhs UD)) = @Fun F X D (vcons (fill c (substitute u (lhs UD))) v2)).
dependent destruction e.
reflexivity.
rewrite jaja in H2.
exact ((term_bis_implies_term_eq H2) (S n)).
apply (@teut_fun_inv F X n D (vcons (fill c (substitute u (lhs UD))) v2) (vcons repeat_D (vnil term)) H2' First).
intro i.
apply term_eq_up_to_weaken.
apply H.
apply term_eq_up_to_weaken.
assumption.
Qed.

(** UUU... is a normal form. *)
Lemma normal_form_repeat_U :
  normal_form UD_trs repeat_U.
Proof.
(** This proof is just a copy of the DDD... proof. *)
intros [c [r [u [H1 H2]]]].
destruct H1 as [H1 | [H1 | []]].

rewrite <- H1 in *|-.
clear H1.
assert (H := (term_bis_implies_term_eq H2) (S (hole_depth c))).
rewrite (peek_eq repeat_U) in H.
dependent destruction H.
assert (H' := H First).
simpl in H'.
clear x.

induction c.

rewrite (peek_eq repeat_U) in H2.
inversion_clear H2.

rewrite (peek_eq repeat_U) in H2.
(*intro x0.*)
assert (d : f = U).
inversion_clear H2.
reflexivity.

revert e H2 H H'.
dependent rewrite d.
intro e.
assert (ij : i = 0 /\ j = 0).
destruct i as [| [| i]]; auto; discriminate e.
revert e v0 v1.
rewrite (proj1 ij).
rewrite (proj2 ij).
intros e v1 v2 H2 H H'.
clear f i j d ij.
apply IHc; clear IHc.

(* this part is quite ugly *)
apply term_eq_implies_term_bis.
intro n.
assert (H2' : term_eq_up_to (S n) (@Fun F X U (vcons (fill c (substitute u (lhs DU))) v2)) (U @ repeat_U)).
assert (jaja : fill (@CFun F X U 0 0 e v1 c v2) (substitute u (lhs DU)) = @Fun F X U (vcons (fill c (substitute u (lhs DU))) v2)).
dependent destruction e.
reflexivity.
rewrite jaja in H2.
exact ((term_bis_implies_term_eq H2) (S n)).
apply (@teut_fun_inv F X n U (vcons (fill c (substitute u (lhs DU))) v2) (vcons repeat_U (vnil term)) H2' First).
intro i.
apply term_eq_up_to_weaken.
apply H.
apply term_eq_up_to_weaken.
assumption.

(** Almost the same argument follows for [r=UD] instead of [r=DU]. *)

rewrite <- H1 in *|-.
clear H1.
assert (H := (term_bis_implies_term_eq H2) (S (S (hole_depth c)))).
rewrite (peek_eq repeat_U) in H.
dependent destruction H.
assert (H' := H First).
rewrite (peek_eq repeat_U) in H'.
dependent destruction H'.
assert (H' := H0 First).
simpl in H'.

(* idea, make [=]1 from x0 *)
assert (y0 : term_eq_up_to 1 (@Fun F X U v) (fill c (@Fun F X U (vmap (substitute u) (vcons (D @@ varx!) (vnil fterm)))))).
(*assert (y0 : @Fun F X D v [=] fill c (@Fun F X D (vmap (substitute u) (vcons (U @@ 1 !) (vnil fterm))))).*)
rewrite x0.
apply term_eq_up_to_refl.
clear x0.

induction c.

assert (H3 := (term_bis_implies_term_eq H2) 2).
rewrite (peek_eq repeat_U) in H3.
dependent destruction H3.
assert (H3 := H1 First).
rewrite (peek_eq repeat_U) in H3.
dependent destruction H3.

rewrite (peek_eq repeat_U) in H2.
(*intro x0.*)
assert (d : f = U).
(*assert (y1 := y0 1).*)
inversion_clear y0.
reflexivity.

(*injection x0.
intros _ d.*)
revert e H2 H y0 H0 H'.
dependent rewrite d.
intro e.
assert (ij : i = 0 /\ j = 0).
destruct i as [| [| i]]; auto; discriminate e.
revert e v1 v2.
rewrite (proj1 ij).
rewrite (proj2 ij).
intros e v1 v2 H2 H y0 H0 H'.
clear f i j d ij.
apply IHc; clear IHc.

(* this part is quite ugly *)
apply term_eq_implies_term_bis.
intro n.
assert (H2' : term_eq_up_to (S n) (@Fun F X U (vcons (fill c (substitute u (lhs UD))) v2)) (U @ repeat_U)).
assert (jaja : fill (@CFun F X U 0 0 e v1 c v2) (substitute u (lhs UD)) = @Fun F X U (vcons (fill c (substitute u (lhs UD))) v2)).
dependent destruction e.
reflexivity.
rewrite jaja in H2.
exact ((term_bis_implies_term_eq H2) (S n)).
apply (@teut_fun_inv F X n U (vcons (fill c (substitute u (lhs UD))) v2) (vcons repeat_U (vnil term)) H2' First).
intro i.
apply term_eq_up_to_weaken.
apply H.
intro i.
dependent destruction i.
apply term_eq_up_to_weaken.
assumption.
dependent destruction i.
apply term_eq_up_to_weaken.
assumption.

clear v0 x H y0 H0 H'.
destruct c.
constructor.
constructor.
simpl.
simpl in H2.
dependent destruction H2.
assert (H3 := H First).
simpl in H3.
clear H.
rewrite (peek_eq repeat_U) in H3.
dependent destruction H3.
revert x.
dependent destruction e.
intro y.
simpl in y.
injection y.
intros _ d.
clear y x H v1 v2 v4.
revert e0.
rewrite <- d.
intro e.
constructor.
constructor.
Qed.

(** DDD... and UUU... are different. *)
Lemma neq_repeat_D_repeat_U :
  ~ repeat_D [~] repeat_U.
Proof.
intro H.
rewrite (peek_eq repeat_D), (peek_eq repeat_U) in H.
inversion H.
Qed.

(** * Rewrite sequences

   We now build our infinite rewrite sequences. *)

Notation Step := (Step UD_trs).
Notation Nil' := (Nil UD_trs).

Notation "s [>] t" := (step UD_trs s t) (at level 40).
Notation "s ->> t" := (sequence UD_trs s t) (at level 40).

Notation "r [ i ]" := (pred r i) (at level 60).
Notation "r [1 i ]" := (fst (projT1 (pred r i))) (at level 60).
Notation "r [2 i ]" := (snd (projT1 (pred r i))) (at level 60).
Notation "r [seq i ]" := (fst (projT2 (pred r i))) (at level 60).
Notation "r [stp i ]" := (snd (projT2 (pred r i))) (at level 60).

Lemma DU_in :
  In DU UD_trs.
Proof.
left; reflexivity.
Qed.

Lemma UD_in :
  In UD UD_trs.
Proof.
right; left; reflexivity.
Qed.

Definition sub_t t (x : X) : term := t.

(** ** psi ->> UUU... *)

Lemma fact_term_bis_UmDSnUSnt :
  forall (m n : nat) (t : term),
    fill (Unc m (Dnc n Hole)) (substitute (sub_t (Unt n t)) (lhs DU))
    [~]
    Unt m (DnUnt (S n) t).
Proof.
intros m n t.
rewrite fill_UmDnHole_t.
unfold DnUnt.
simpl.
rewrite DDnt_eq_DnDt.
apply term_bis_Unt.
apply term_bis_Dnt.
constructor.
intro i; dependent destruction i; [idtac | inversion i].
unfold vmap.
simpl.
constructor.
intro i; dependent destruction i; [idtac | inversion i].
unfold vmap.
simpl.
apply term_bis_refl.
Qed.

Lemma fact_term_eq_UmDnUnt :
  forall (m n : nat) (t : term),
    fill (Unc m (Dnc n Hole)) (substitute (sub_t (Unt n t)) (rhs DU))
    =
    Unt m (DnUnt n t).
Proof.
intros m n t.
rewrite fill_Unc_t.
rewrite fill_Dnc_t.
simpl.
reflexivity.
Qed.

Lemma fact_term_bis_UmDnUnt :
  forall (m n : nat) (t : term),
    fill (Unc m (Dnc n Hole)) (substitute (sub_t (Unt n t)) (rhs DU))
    [~]
    Unt m (DnUnt n t).
Proof.
intros m n t.
rewrite fact_term_eq_UmDnUnt.
apply term_bis_refl.
Qed.

(** Step from U^m D^Sn U^Sn to U^m D^n U^n t. *)
Definition p_UmDSnUSnt_UmDnUnt m n t : Unt m (DnUnt (S n) t) [>] Unt m (DnUnt n t) :=
  Step DU (Unc m (Dnc n Hole)) (sub_t (Unt n t)) DU_in (fact_term_bis_UmDSnUSnt m n t) (fact_term_bis_UmDnUnt m n t).

(** n-step rewrite sequence from U^m D^n U^n t to U^m t. *)
Fixpoint s_UmDnUnt_Umt m n t : Unt m (DnUnt n t) ->> Unt m t :=
  match n return Unt m (DnUnt n t) ->> Unt m t with
  | O   => Nil' (Unt m t)
  | S n => snoc (p_UmDSnUSnt_UmDnUnt m n t) (s_UmDnUnt_Umt m n t)
  end.

(** 2n+1-step rewrite sequence from U^n [psi' n] to U^Sn [psi' Sn]. *)
Definition s_Unpsin_USnpsiSn n : Unt n (psi' n) ->> Unt (S n) (psi' (S n)).
(** Coq 8.3-rc1 does the 'intro n' automatically, but 8.3-beta0-1 needs it. *)
intros.
assert (H : Unt n (DnUnt (S (2 * n)) (U @ psi' (S n))) ->> Unt n (U @ psi' (S n))).
refine (s_UmDnUnt_Umt n (S (2 * n)) (U @ psi' (S n))).
unfold DnUnt in H.
rewrite psin_eq_DS2nUS2nUpsiSn.
simpl.
simpl in H.
unfold DnUnt.
simpl.
rewrite UUnt_eq_UnUt with n (psi' (S n)).
exact H.
Defined.

(** We would have liked to define the above by the following definition
   using [Program], but unfortunately it is not accepted by Coq. Is this
   a bug in [Program]?

[[
Program Definition s_Unpsin_USnpsiSn n : Unt n (psi' n) ->> Unt (S n) (psi' (S n)) :=
  s_UmDnUnt_Umt n (S (2 * n)) (U @ psi' (S n)).
Next Obligation.
symmetry.
unfold DnUnt.
rewrite psin_eq_DS2nUS2nUpsiSn.
reflexivity.
Defined.
Next Obligation.
rewrite UUnt_eq_UnUt.
reflexivity.
Defined.
]]
*)

(** Rewrite sequence from [psi] to U^n [psi' n]. *)
Fixpoint s_psi_Unpsin n : psi ->> Unt n (psi' n) :=
  match n return psi ->> Unt n (psi' n) with
  | O   => Nil' psi
  | S n => append (s_psi_Unpsin n) (s_Unpsin_USnpsiSn n)
  end.

Lemma converges_Unpsin : converges (fun n => Unt n (psi' n)) repeat_U.
Proof.
intro d.
exists d.
intros m H.
simpl.
apply term_eq_up_to_weaken_generalized with m.
assumption.
apply term_eq_up_to_n_Unt_repeat_U.
Qed.

(** Omega-step rewrite sequence from [psi] to UUU... *)
Definition s_psi_repeat_U : psi ->> repeat_U :=
  Lim s_psi_Unpsin converges_Unpsin.

(** ** psi ->> DDD... *)

Lemma fact_term_bis_DmUSnDSnt :
  forall (m n : nat) (t : term),
    fill (Dnc m (Unc n Hole)) (substitute (sub_t (Dnt n t)) (lhs UD))
    [~]
    Dnt m (UnDnt (S n) t).
Proof.
intros m n t.
rewrite fill_DmUnHole_t.
unfold UnDnt.
simpl.
rewrite UUnt_eq_UnUt.
apply term_bis_Dnt.
apply term_bis_Unt.
constructor.
intro i; dependent destruction i; [idtac | inversion i].
unfold vmap.
simpl.
constructor.
intro i; dependent destruction i; [idtac | inversion i].
unfold vmap.
simpl.
apply term_bis_refl.
Qed.

Lemma fact_term_eq_DmUnDnt :
  forall (m n : nat) (t : term),
    fill (Dnc m (Unc n Hole)) (substitute (sub_t (Dnt n t)) (rhs UD))
    =
    Dnt m (UnDnt n t).
Proof.
intros m n t.
rewrite fill_Dnc_t.
rewrite fill_Unc_t.
simpl.
reflexivity.
Qed.

Lemma fact_term_bis_DmUnDnt :
  forall (m n : nat) (t : term),
    fill (Dnc m (Unc n Hole)) (substitute (sub_t (Dnt n t)) (rhs UD))
    [~]
    Dnt m (UnDnt n t).
Proof.
intros m n t.
rewrite fact_term_eq_DmUnDnt.
apply term_bis_refl.
Qed.

(* Step from D^m U^Sn D^Sn t to D^m U^n D^n t. *)
Definition p_DmUSnDSnt_DmUnDnt m n t : Dnt m (UnDnt (S n) t) [>] Dnt m (UnDnt n t) :=
  Step UD (Dnc m (Unc n Hole)) (sub_t (Dnt n t)) UD_in (fact_term_bis_DmUSnDSnt m n t) (fact_term_bis_DmUnDnt m n t).

(* n-step rewrite sequence from D^m U^n D^n t to D^m t. *)
Fixpoint s_DmUnDnt_Dmt m n t : Dnt m (UnDnt n t) ->> Dnt m t :=
  match n return Dnt m (UnDnt n t) ->> Dnt m t with
  | O   => Nil' (Dnt m t)
  | S n => snoc (p_DmUSnDSnt_DmUnDnt m n t) (s_DmUnDnt_Dmt m n t)
  end.

(** 2n-step rewrite sequence from D^n U^2n [psi' n] to D^Sn U2Sn [psi' Sn]. *)
Definition s_DnU2npsin_DSnU2SnpsiSn n : Dnt n (Unt (2 * n) (psi' n)) ->> Dnt (S n) (Unt (2 * (S n)) (psi' (S n))).
(** Coq 8.3-rc1 does the 'intro n' automatically, but 8.3-beta0-1 needs it. *)
intros.
assert (H : Dnt n (UnDnt (2 * n) (D @ Unt (2 * (S n)) (psi' (S n)))) ->> Dnt n (D @ (Unt (2 * S n)) (psi' (S n)))).
refine (s_DmUnDnt_Dmt n (2 * n) (D @ (Unt (2 * (S n)) (psi' (S n))))).
unfold UnDnt in H.
rewrite psin_eq_DS2nUS2nUpsiSn.
unfold DnUnt.
simpl.
rewrite DDnt_eq_DnDt.
simpl in H.
rewrite <- plus_n_Sm in H.
rewrite <- plus_n_Sm.
simpl in H.
simpl.
rewrite <- UUnt_eq_UnUt.
rewrite DDnt_eq_DnDt.
exact H.
Defined.

(** We would have liked to define the above by the following definition
   using [Program], but unfortunately it is not accepted by Coq. Is this
   a bug in [Program]?

[[
Program Definition s_DnU2npsin_DSnU2SnpsiSn n : Dnt n (Unt (2 * n) (psi' n)) ->> Dnt (S n) (Unt (2 * (S n)) (psi' (S n))) :=
  s_DmUnDnt_Dmt n (2 * n) (D @ (Unt (2 * (S n)) (psi' (S n)))).
Next Obligation.
symmetry.
unfold UnDnt.
rewrite psin_eq_DS2nUS2nUpsiSn.
unfold DnUnt.
simpl.
rewrite DDnt_eq_DnDt.
rewrite <- plus_n_Sm.
rewrite <- UUnt_eq_UnUt.
reflexivity.
Defined.
Next Obligation.
rewrite DDnt_eq_DnDt.
reflexivity.
Defined.
]]
*)

(** Rewrite sequence from [psi] to D^Sn U^2Sn [psi' Sn]. *)
Fixpoint s_psi_DSnU2SnpsiSn n : psi ->> Dnt (S n) (Unt (2 * (S n)) (psi' (S n))) :=
  match n return psi ->> Dnt (S n) (Unt (2 * (S n)) (psi' (S n))) with
  | O   => s_DnU2npsin_DSnU2SnpsiSn 0
  | S n => append (s_psi_DSnU2SnpsiSn n) (s_DnU2npsin_DSnU2SnpsiSn (S n))
  end.

Lemma converges_DSnU2SnpsiSn : converges (fun n => Dnt (S n) (Unt (2 * (S n)) (psi' (S n)))) repeat_D.
Proof.
intro d.
exists d.
intros m H.
simpl.
apply term_eq_up_to_weaken_generalized with m.
assumption.
rewrite DDnt_eq_DnDt.
apply term_eq_up_to_n_Dnt_repeat_D.
Qed.

(* Omega-step reduction from [psi] to DDD... *)
Definition s_psi_repeat_D : psi ->> repeat_D :=
  Lim s_psi_DSnU2SnpsiSn converges_DSnU2SnpsiSn.

(** * Well-formedness of the rewrite sequences

   It should be noted that at this point, nothing has been said yet about
   well-formedness of the two rewrite sequences. Furthermore, they might
   not be convergent.

   So we proceed by proving the [wf] property for the rewrite sequences.
   Convergence seems our of our reach at this point unfortunately. *)

(** ** Well-formedness of psi ->> UUU...

   We first prove all finite prefixes are indeed finite. Then we prove that
   every branch of the [Lim] constructor is embedded in the next branch. *)

Lemma finite_s_UmDnUnt_Umt :
  forall m n t, finite (s_UmDnUnt_Umt m n t).
Proof.
induction n as [| n IH]; intro t; simpl.
exact I.
apply snoc_finite.
apply IH.
Qed.

Lemma finite_s_Unpsin_USnpsiSn :
  forall n, finite (s_Unpsin_USnpsiSn n).
Proof.
intro n.
unfold s_Unpsin_USnpsiSn; simpl.
unfold eq_rect_r; repeat (elim_eq_rect ; simpl).
apply finite_s_UmDnUnt_Umt.
Qed.

Lemma finite_s_psi_Unpsin :
  forall n : nat, finite (s_psi_Unpsin n).
Proof.
induction n as [| n IH]; simpl.
exact I.
apply append_finite.
exact IH.
apply finite_s_Unpsin_USnpsiSn.
Qed.

(** The following lemmas help establish [wf]. They are not pretty. *)

Lemma s_UmDnUnt_Umt_is_cons :
  forall m n t,
    exists s, exists r : _ ->> s, exists p : s [>] _,
      s_UmDnUnt_Umt m (S n) t = Cons r p.
Proof.
induction n; intro t; simpl.
exists (Unt m (DnUnt 1 t)).
exists (Nil' (Unt m (DnUnt 1 t))).
exists (p_UmDSnUSnt_UmDnUnt m 0 t).
reflexivity.
simpl in IHn.
specialize IHn with t.
destruct IHn as [s [r [p IH]]].
rewrite IH.
simpl.
exists s.
exists (snoc (p_UmDSnUSnt_UmDnUnt m (S n) t) r).
exists p.
reflexivity.
Qed.

Lemma embed_strict_append_Unpsin_USnpsiSn :
  forall t n (r : t ->> Unt n (psi' n)),
    embed_strict r (append r (s_Unpsin_USnpsiSn n)).
Proof.
intro t.
destruct n as [| n]; simpl;
unfold s_Unpsin_USnpsiSn; simpl; unfold eq_rect_r; repeat (elim_eq_rect ; simpl); intro r.
exists (inl _ tt).
apply embed_refl.
revert r.
rewrite <- (plus_n_Sm n).
rewrite <- plus_n_O.
intro r.
destruct (s_UmDnUnt_Umt_is_cons (S n) (n + n) (U @ psi' (S (S n)))) as [s [q [p H]]].
rewrite H.
exists (inl _ tt).
simpl.
apply embed_append_right.
Qed.

Lemma wf_s_psi_Unpsin :
  forall n : nat, wf (s_psi_Unpsin n).
Proof.
intro n.
apply wf_finite.
apply finite_s_psi_Unpsin.
Qed.

Lemma wf_s_psi_repeat_U :
  wf s_psi_repeat_U.
Proof.
split.
apply wf_s_psi_Unpsin.
intros n m H.
induction H; simpl.
apply embed_strict_append_Unpsin_USnpsiSn.
apply embed_strict_trans with psi (Unt m (psi' m)) (s_psi_Unpsin m).
apply IHle.
apply embed_strict_append_Unpsin_USnpsiSn.
Qed.

(** ** Well-formedness of psi ->> DDD...

   We first prove all finite prefixes are indeed finite. Then we prove that
   every branch of the [Lim] constructor is embedded in the next branch. *)

Lemma finite_s_DmUnDnt_Dmt :
  forall m n t, finite (s_DmUnDnt_Dmt m n t).
Proof.
induction n as [| n IH]; intro t; simpl.
exact I.
apply snoc_finite.
apply IH.
Qed.

(** It is very unclear to me why we have to take this statement apart. *)
Lemma finite_s_DnU2npsin_DSnU2SnpsiSn_helper :
  forall n,
       finite
     (eq_rect
        (Dnt (n + (n + 0)) (D @ U @ Unt (n + (n + 0)) (U @ psi' (S n))))
        (fun y : term =>
         Dnt n (Unt (n + (n + 0)) y) ->>
         Dnt n (D @ U @ U @ Unt (n + (n + 0)) (psi' (S n))))
        (eq_rect (U @ Unt (n + (n + 0)) (psi' (S n)))
           (fun t : term =>
            Dnt n (Unt (n + (n + 0)) (Dnt (n + (n + 0)) (D @ U @ t))) ->>
            Dnt n (D @ U @ U @ Unt (n + (n + 0)) (psi' (S n))))
           (s_DmUnDnt_Dmt n (n + (n + 0))
              (D @ U @ U @ Unt (n + (n + 0)) (psi' (S n))))
           (Unt (n + (n + 0)) (U @ psi' (S n)))
           (UUnt_eq_UnUt (n + (n + 0)) (psi' (S n))))
        (D @ Dnt (n + (n + 0)) (U @ Unt (n + (n + 0)) (U @ psi' (S n))))
        (eq_sym
           (DDnt_eq_DnDt (n + (n + 0))
              (U @ Unt (n + (n + 0)) (U @ psi' (S n)))))).
Proof.
intro n.
repeat (elim_eq_rect ; simpl).
apply finite_s_DmUnDnt_Dmt.
Qed.

Lemma finite_s_DnU2npsin_DSnU2SnpsiSn :
  forall n, finite (s_DnU2npsin_DSnU2SnpsiSn n).
Proof.
intro n.
unfold s_DnU2npsin_DSnU2SnpsiSn; simpl.
unfold eq_rect_r; repeat (elim_eq_rect ; simpl).
apply finite_s_DnU2npsin_DSnU2SnpsiSn_helper.
Qed.

(** It is very unclear to me why we have to take this statement apart. *)
Lemma finite_s_psi_DSnU2SnpsiSn_helper :
   finite
     (eq_rect (DnUnt 1 (U @ psi' 1))
        (fun y : term => y ->> (D @ U @ U @ psi' 1))
        (Nil' (D @ U @ U @ psi' 1)) (psi' 0) (eq_sym (psin_eq_DS2nUS2nUpsiSn 0))).
Proof.
elim_eq_rect; simpl.
exact I.
Qed.

Lemma finite_s_psi_DSnU2SnpsiSn :
  forall n : nat, finite (s_psi_DSnU2SnpsiSn n).
Proof.
induction n as [| n IH]; simpl.
unfold s_DnU2npsin_DSnU2SnpsiSn; simpl.
unfold eq_rect_r; repeat (elim_eq_rect; simpl).
apply finite_s_psi_DSnU2SnpsiSn_helper.
apply append_finite.
exact IH.
exact (finite_s_DnU2npsin_DSnU2SnpsiSn (S n)).
Qed.

(** We use this predicate and the following lemmas to prove well-formedness.
   Yes, this is ugly and a bit of a hack. *)
Fixpoint is_cons s t (r : s ->> t) : Prop :=
  match r with
  | Nil _          => False
  | Cons _ _ q _ _ => True
  | Lim _ _ f t c  => False
  end.

Lemma is_cons_snoc :
  forall s t u (p : s [>] t) (r : t ->> u),
    is_cons r ->
    is_cons (snoc p r).
Proof.
intros.
destruct r; simpl.
exact I.
exact I.
inversion H.
Qed.

Lemma append_is_cons :
  forall s t u (r : s ->> t) (q : t ->> u),
    is_cons q ->
    embed_strict r (append r q).
Proof.
intros.
destruct q.
elim H.
simpl.
exists (inl _ tt).
simpl.
apply embed_append_right.
elim H.
Qed.

Lemma is_cons_s_DmUnDnt_Dmt :
  forall m n t, is_cons (s_DmUnDnt_Dmt m (S n) t).
Proof.
induction n as [| n IH]; intro t; simpl.
exact I.
apply is_cons_snoc.
apply IH.
Qed.

(** It is very unclear to me why we have to take this statement apart. *)
Lemma is_cons_s_DnU2npsin_DSnU2SnpsiSn_helper :
  forall n,
   is_cons
     (eq_rect
        (Dnt (S n + (S n + 0))
           (D @ U @ Unt (S n + (S n + 0)) (U @ psi' (S (S n)))))
        (fun y : term =>
         Dnt (S n) (Unt (S n + (S n + 0)) y) ->>
         Dnt (S n) (D @ U @ U @ Unt (S n + (S n + 0)) (psi' (S (S n)))))
        (eq_rect (U @ Unt (S n + (S n + 0)) (psi' (S (S n))))
           (fun t : term =>
            Dnt (S n)
              (Unt (S n + (S n + 0)) (Dnt (S n + (S n + 0)) (D @ U @ t))) ->>
            Dnt (S n) (D @ U @ U @ Unt (S n + (S n + 0)) (psi' (S (S n)))))
           (s_DmUnDnt_Dmt (S n) (S n + (S n + 0))
              (D @ U @ U @ Unt (S n + (S n + 0)) (psi' (S (S n)))))
           (Unt (S n + (S n + 0)) (U @ psi' (S (S n))))
           (UUnt_eq_UnUt (S n + (S n + 0)) (psi' (S (S n)))))
        (D @
         Dnt (S n + (S n + 0))
           (U @ Unt (S n + (S n + 0)) (U @ psi' (S (S n)))))
        (eq_sym
           (DDnt_eq_DnDt (S n + (S n + 0))
              (U @ Unt (S n + (S n + 0)) (U @ psi' (S (S n))))))).
Proof.
intro n.
simpl.
repeat (elim_eq_rect ; simpl).
apply is_cons_snoc.
rewrite <- plus_n_Sm.
exact (is_cons_s_DmUnDnt_Dmt (S n) (n + (n + 0)) (D @ U @ U @ U @ Unt (S (n + (n + 0))) (psi' (S (S n))))).
Qed.

Lemma is_cons_s_DnU2npsin_DSnU2SnpsiSn :
  forall n, 0 < n -> is_cons (s_DnU2npsin_DSnU2SnpsiSn n).
Proof.
intros n H.
unfold s_DnU2npsin_DSnU2SnpsiSn; simpl.
unfold eq_rect_r; repeat (elim_eq_rect ; simpl).
destruct n.
inversion H.
apply is_cons_s_DnU2npsin_DSnU2SnpsiSn_helper.
Qed.

Lemma embed_strict_append_DnU2npsin_DSnU2SnpsiSn :
  forall t n (r : t ->> Dnt (S n) (Unt (2 * (S n)) (psi' (S n)))),
    embed_strict r (append r (s_DnU2npsin_DSnU2SnpsiSn (S n))).
Proof.
intros.
apply append_is_cons.
apply is_cons_s_DnU2npsin_DSnU2SnpsiSn.
intuition.
Qed.

Lemma wf_s_psi_DSnU2SnpsiSn :
  forall n : nat, wf (s_psi_DSnU2SnpsiSn n).
Proof.
intro n.
apply wf_finite.
apply finite_s_psi_DSnU2SnpsiSn.
Qed.

Lemma wf_s_psi_repeat_D :
  wf s_psi_repeat_D.
Proof.
split.
apply wf_s_psi_DSnU2SnpsiSn.
intros n m H.
induction H; simpl.
apply embed_strict_append_DnU2npsin_DSnU2SnpsiSn.
apply (embed_strict_trans (q := s_psi_DSnU2SnpsiSn m)).
apply IHle.
apply embed_strict_append_DnU2npsin_DSnU2SnpsiSn.
Qed.

(** * Conclusions

   We conclude by taking our results together, showing this TRS does not
   have the unique normal forms property. We then generalise this to
   show that weak orthogonality does not imply unique normal forms. *)

Lemma no_unique_normal_forms_UD :
  ~ unique_normal_forms UD_trs.
Proof.
intro H.
apply neq_repeat_D_repeat_U.
apply H with psi s_psi_repeat_D s_psi_repeat_U.
exact wf_s_psi_repeat_D.
exact wf_s_psi_repeat_U.
exact normal_form_repeat_D.
exact normal_form_repeat_U.
Qed.

Lemma no_unique_normal_forms_wo :
  ~ forall F X trs, weakly_orthogonal (F := F) (X := X) trs -> unique_normal_forms trs.
Proof.
intro H.
apply no_unique_normal_forms_UD.
apply H.
apply weakly_orthogonal_UD.
Qed.


Require Export Paths Fibrations.

(** For compatibility with Coq 8.2. *)
Unset Automatic Introduction.

(** A space [A] is contractible if there is a point [x : A] and a
   (pointwise) homotopy connecting the identity on [A] to the constant
   map at [x].  Thus an element of [is_contr A] is a pair whose
   first component is a point [x] and the second component is a
   pointwise retraction of [A] to [x]. *)

Definition is_contr A := {x : A & forall y : A, y == x}.

(** If a space is contractible, then any two points in it are
   connected by a path in a canonical way. *)

Lemma contr_path {A} (x y : A) : (is_contr A) -> (x == y).
Proof.
  intros A x y.
  intro H.
  destruct H as (z,p).
  path_via z.
Defined.

(** Similarly, any two parallel paths in a contractible space are homotopic.  *)

Lemma contr_path2 {A} {x y : A} (p q : x == y) : (is_contr A) -> (p == q).
Proof.
  intros X x y p q.
  intro ctr.
  destruct ctr as (c, ret).
  path_via (ret x @ !ret y).
  moveleft_onright.
  moveright_onleft.
  apply opposite.
  exact (! trans_is_concat_opp p (ret x)  @  map_dep ret p ).
  moveright_onright.
  moveleft_onleft.
  exact (! trans_is_concat_opp q (ret x)  @  map_dep ret q).
Defined.

(** It follows that any space of paths in a contractible space is contractible. *)

Lemma contr_pathcontr {A} (x y : A) : is_contr A -> is_contr (x == y).
Proof.
  intros A x y.
  intro ctr.
  exists (contr_path x y ctr).
  intro p.
  apply contr_path2.
  assumption.
Defined.

(** The total space of any based path space is contractible. *)

Lemma pathspace_contr {X} (x:X) : is_contr (sigT (paths x)).
Proof.
  intros X x.
  exists (x ; idpath x).
  intros [y p].
  path_induction.
Defined.

Lemma pathspace_contr' {X} (x:X) : is_contr { y:X  &  x == y }.
Proof.
  intros X x.
  exists (existT (fun y => x == y) x (idpath x)).
  intros [y p].
  path_induction.
Defined.

Lemma pathspace_contr_opp {X} (x:X) : is_contr { y:X & y == x }.
Proof.
  intros X x.
  exists (existT (fun y => y == x) x (idpath x)).
  intros [y p].
  path_induction.
Defined.

(** The unit type is contractible. *)

Lemma unit_contr : is_contr unit.
Proof.
  exists tt.
  intro y.
  induction y.
  auto.
Defined.

Hint Resolve unit_contr.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (x : natural) : natural :=
  plus lf2 (mult y lf2).


Require Import RelationClasses.
Require Import OrderedType.

Module OT_Equiv (O: OrderedType).

  Theorem Equiv: Equivalence O.eq.
  Proof.
    intros.
    eapply Build_Equivalence.
    unfold Reflexive; apply O.eq_refl; auto.
    unfold Symmetric; apply O.eq_sym; auto.
    unfold Transitive; apply O.eq_trans; auto.
  Qed.

  Theorem Leibniz_eq: forall {x} {x'},
    Logic.eq x x' -> O.eq x x'.
  Proof.
    intros; rewrite H in *; try apply O.eq_refl.
  Qed.

End OT_Equiv.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (x : natural) : natural := mult (Succ x) lf1.


(******************************************************************************)
(* Dr Daniel Kirk (c) 2021                                                    *)
(******************************************************************************)
(*         M1 \oplus M2 == the lmodType given by pair_lmodType in ssralg.v    *)
(*                         This is an implementation of the direct sum of two *)
(*                         lmodTypes of the same ring.                        *)
(* \bigoplus_(f in L) I == the lmodType built up iteratively, where L : seq S *)
(*                         for S : eqType and I : S -> lmodType R             *)
(*                         \bigoplus_(f in nil) I is lmodNull R whilst        *)
(*                         \bigoplus_(f in a::L) I is                         *)
(*                               (I a) \oplus (\bigoplus_(f in L) I)          *)
(*                         This is an implementation of the direct sum of an  *)
(*                         arbitrary number of lmodTypes. Note that L is not  *)
(*                         a list of lmodTypes but of some eqType S, which    *)
(*                         are 'converted' to lmodTypes by                    *)
(*                           I : S -> lmodType R.                             *)
(*  \bigoplus_(f : F) I == the lmodType equal to \bigoplus_(f in (enum F)) I  *)
(*        \bigoplus_F I == equivalent to \bigoplus_(f : F) I                  *)
(*          \bigoplus I == equivalent to \bigoplus_(f : F) I                  *)
(*                         where I : F -> lmodType R                          *)
(******************************************************************************)
(* The following constructions and lemmas relate to M \oplus N,               *)
(* the direct sum of the pair of lmodTypes M and N                            *)
(******************************************************************************)
(*  \proj1^(M,N)   == the linear projection from M \oplus N to M              *)
(*  \proj2^(M,N)   == the linear projection from M \oplus N to N              *)
(*  \incl1^(M,N)   == the linear inclusion from M to M \oplus N               *)
(*  \incl2^(M,N)   == the linear inclusion from N to M \oplus N               *)
(*  incl1_injective  == a proof that \incl1^(M,N) is injective                *)
(*  incl2_injective  == a proof that \incl2^(M,N) is injective                *)
(*  proj1_incl1K     == a proof of \proj1^(M,N) (\incl1^(M,N) x) = x          *)
(*  proj2_incl2K     == a proof of \proj2^(M,N) (\incl2^(M,N) x) = x          *)
(*  proj1_incl20     == a proof of \proj1^(M,N) (\incl2^(M,N) x) = 0          *)
(*  proj2_incl10     == a proof of \proj2^(M,N) (\incl1^(M,N) x) = 0          *)
(*  incl_proj12_sum  == a proof that any x : M \oplus N can be written        *)
(*                         x = \incl1^(M,N) (\proj1^(M,N) x)                  *)
(*                              + \incl2^(M,N) (\proj2^(M,N) x)               *)
(*  incl_proj12_idem == a proof that rewriting with incl_proj12_sum is        *)
(*                         idempotent                                         *)
(******************************************************************************)
(* Let M N M1 M2 N1 N2 : lmodType R.                                          *)
(* We define construction for combining linear maps so to be compatible       *)
(* with direct sums                                                           *)
(******************************************************************************)
(* Let f1 : {linear M1 -> N1} and f2 : {linear M2 -> N2}                      *)
(* \diagmap(f,g) == the linear map : M1 \oplus M2 -> N1 \oplus N2             *)
(*                         given by \diagmap(f,g) (x,y) = (f x, g y)          *)
(******************************************************************************)
(* Let f1 : {linear M1 -> N} and f2 : {linear M2 -> N}                        *)
(* \rowmap(f,g) == the linear map : M1 \oplus M2 -> N                         *)
(*                         given by \rowmap(f,g) (x,y) = f x + g y            *)
(******************************************************************************)
(* Let f1 : {linear M -> N1} and f2 : {linear M -> N2}                        *)
(* \colmap(f,g) == the linear map : M -> N1 \oplus N2                         *)
(*                         given by \colmap(f,g) x = (f x, g x)               *)
(******************************************************************************)
(* The following constructions and lemmas relate to \bigoplus_(f : F) I,      *)
(* the direct sum of the lmodTypes given by (I : F -> lmodType R), and F is a *)
(* finite index set (i.e. a finType)                                          *)
(******************************************************************************)
(*  \proj_f^(I)    == the linear projection from \bigoplus I to (I f),        *)
(*                 for f : F. This function is surjective                     *)
(*  \incl_f^(I)    == the linear inclusion from (I f) to \bigoplus I,         *)
(*                 for f : F. This function is injective                      *)
(*  incl_injective == a proof that \incl_f^(I) is injective for f : F         *)
(*  proj_inclK     == a proof that \incl_f^(I) and \proj_f^(I) cancel         *)
(*  proj_incl0     == a proof that \incl_f^(I) and \proj_(f')^(I) equals zero *)
(*                    if f != f'                                              *)
(*  incl_proj_sum  == rewrites element x : \bigoplus I as                     *)
(*                        \sum_(f : F)\incl_f^(I) (\proj_f^(I) x)             *)
(*  incl_proj_idem       ==  a proof that rewriting with incl_proj_sum is     *)
(*                         idempotent                                         *)
(******************************************************************************)
(* The following constructions are used to split and unsplit the direct sum   *)
(* of two direct sums, that is (\bigoplus J) \oplus (\bigoplus K).            *)
(* Doing this involves:                                                       *)
(*  1) three index sets F, G and H,                                           *)
(*  2) a function GH_F : G + H -> F, connecting the sum of G and H to F       *)
(*  3) a proof enumB : enum F = map F_GH (enum sum_finType G H) which         *)
(* establishes that GH_F is an 'isomorphism' of G + H and F as finTypes,      *)
(* and the notations J = I \o GH_F \o inl and K = I \o GH_F \o inr.           *)
(******************************************************************************)
(*     split == a linear function from \bigoplus I to                         *)
(*                    (\bigoplus J) \oplus (\bigoplus K)                      *)
(*   unsplit == a linear function from (\bigoplus J) \oplus (\bigoplus K)     *)
(*                    to \bigoplus I                                          *)
(*  splitK   == a proof that split and unsplit cancel                         *)
(*  unsplitK == a proof that unsplit and split cancel                         *)
(******************************************************************************)
(* DirectSum_UniversalProperty == *)
(******************************************************************************)

From Coq.Init Require Import Notations Datatypes.
Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun seq.
From mathcomp Require Import eqtype choice fintype bigop generic_quotient tuple finfun.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Modules Linears.
Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Include GRing.

Open Scope  lmod_scope.

Section Helpers.
  Variable (R : ringType) (S : finType) (X : lmodType R) (f : S*S -> X).
  Lemma big_pair_diag_eq :
    \sum_(i : S*S | i.2 == i.1)f i
      = \sum_(i : S) f (i, i).
  Proof.
    have : forall (i : S) (_ : true), f (i, i) = \sum_(j : S) if (j == i) then f (i, j) else 0
    by move=>i _;
    rewrite -big_mkcond (big_pred1 i).
    move=> H; rewrite (eq_bigr _ H); clear H.
    by rewrite pair_bigA -big_mkcond
    (eq_bigr (fun i => f (i.1,i.2)) _)=>/=;
      [|move=>i _; destruct i=>/=].
  Qed.
End Helpers.

Reserved Notation "\bigoplus_ i F"
(at level 36, F at level 36, i at level 50,
  right associativity,
        format "'[' \bigoplus_ i '/ ' F ']'").

Reserved Notation "\bigoplus F"
(at level 36, F at level 36,
  right associativity,
        format "'[' \bigoplus F ']'").

Reserved Notation "\bigoplus_ ( i : t ) F"
(at level 36, F at level 36, i at level 50,
        format "'[' \bigoplus_ ( i : t ) '/ ' F ']'").

Reserved Notation "\bigoplus_ ( i < n ) F"
(at level 36, F at level 36, i, n at level 50,
        format "'[' \bigoplus_ ( i < n ) F ']'").

Reserved Notation "\bigoplus_ ( i 'in' A ) F"
(at level 36, F at level 36, i, A at level 50,
        format "'[' \bigoplus_ ( i 'in' A ) '/ ' F ']'").

Reserved Notation "\proj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj^( I )_ f ']'").

Reserved Notation "\incl^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \incl^( I )_ f ']'").

Reserved Notation "\proj_ f ^( I ) "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj_ f '^(' I ) ']'").

Reserved Notation "\incl_ f ^( I )"
(at level 36, f at level 36, I at level 36,
  format "'[' \incl_ f '^(' I ) ']'").

Module dsLmod.
  Module Pair.
    Section Def.
      Variable (R : ringType) (m1 m2 : lmodType R).

      Section Injection.
        Definition incl1_raw := fun x : m1 => (x,zero m2) : pair_lmodType m1 m2.
        Definition incl2_raw := fun x : m2 => (zero m1, x) : pair_lmodType m1 m2.

        Lemma incl1_lin : linear incl1_raw.
        Proof. rewrite /(additive (pair^~0%R))/morphism_2=>r x y.
          rewrite /scale/add=>/=.
          by rewrite /add_pair/scale_pair scaler0 addr0. Qed.
        Lemma incl2_lin : linear incl2_raw.
        Proof. rewrite /(additive (pair^~0%R))/morphism_2=>r x y.
          rewrite /scale/add=>/=.
          by rewrite /add_pair/scale_pair scaler0 addr0. Qed.

        Lemma incl1_injective : injective incl1_raw.
        Proof. by move=>x y H; inversion H. Qed.
        Lemma incl2_injective : injective incl2_raw.
        Proof. by move=>x y H; inversion H. Qed.

        Definition incl1 := Linear incl1_lin.
        Definition incl2 := Linear incl2_lin.
      End Injection.

      Section Projection.
        Definition proj1_raw := fun x : pair_lmodType m1 m2 => x.1.
        Definition proj2_raw := fun x : pair_lmodType m1 m2 => x.2.

        Lemma proj1_lin : linear proj1_raw.
        Proof. by rewrite /morphism_2. Qed.
        Lemma proj2_lin : linear proj2_raw.
        Proof. by rewrite /morphism_2. Qed.

        Definition proj1 := Linear proj1_lin.
        Definition proj2 := Linear proj2_lin.

        Lemma proj1_incl1K x : proj1 (incl1 x) = x. Proof. by []. Qed.
        Lemma proj2_incl2K x : proj2 (incl2 x) = x. Proof. by []. Qed.
        Lemma proj1_incl20 x : proj1 (incl2 x) = 0. Proof. by []. Qed.
        Lemma proj2_incl10 x : proj2 (incl1 x) = 0. Proof. by []. Qed.
      End Projection.

      Lemma incl_proj_sum x : x = incl1 (proj1 x) + incl2 (proj2 x).
      Proof. rewrite /(add _)/=/add_pair addr0 add0r;
        by destruct x.
      Qed.
    End Def.

    Section Morphisms.
      Section MorphismsToDS.
        Variable (R : ringType) (M N1 N2 : lmodType R)
          (f1 : {linear M -> N1}) (f2 : {linear M -> N2}).

        Definition to_ds_raw : M -> (pair_lmodType N1 N2)
          := fun x => (incl1 _ _ (f1 x)) + (incl2  _ _ (f2 x)).

        Lemma to_ds_lin : linear to_ds_raw.
        Proof. rewrite/to_ds_raw=>r x y.
        by rewrite !linearP addrACA scalerDr. Qed.
        Definition to_ds : {linear M -> (pair_lmodType N1 N2)}
          := Linear to_ds_lin.

      End MorphismsToDS.

      Section MorphismsFromDS.
        Variable (R : ringType) (M1 M2 N : lmodType R)
          (f1 : {linear M1 -> N}) (f2 : {linear M2 -> N}).

        Definition from_ds_raw : (pair_lmodType M1 M2) -> N
          := fun x => (f1 (proj1 _ _ x)) + (f2 (proj2  _ _ x)).

        Lemma from_ds_lin : linear from_ds_raw.
        Proof. rewrite/from_ds_raw=>r x y.
        by rewrite !linearP addrACA scalerDr. Qed.

        Definition from_ds : {linear (pair_lmodType M1 M2) -> N}
          := Linear from_ds_lin.

      End MorphismsFromDS.

      Section MorphismsDiag.
        Variable (R : ringType) (M1 M2 N1 N2 : lmodType R)
          (f1 : {linear M1 -> N1}) (f2 : {linear M2 -> N2}).

        Definition diag_raw : (pair_lmodType M1 M2) -> (pair_lmodType N1 N2)
          := fun x => (incl1 _ _ (f1 (proj1 _ _ x))) + (incl2 _ _ (f2 (proj2  _ _ x))).

        Lemma diag_lin : linear diag_raw.
        Proof. rewrite/diag_raw=>r x y.
        by rewrite !linearP addrACA scalerDr. Qed.

        Definition diag : {linear (pair_lmodType M1 M2) -> (pair_lmodType N1 N2)}
          := Linear diag_lin.
      End MorphismsDiag.

      Section MorphismsDiagCompositions.
        Variable (R : ringType) (M1 M2 N1 N2 O1 O2 : lmodType R)
          (f1 : {linear M1 -> N1}) (f2 : {linear M2 -> N2})
          (g1 : {linear N1 -> O1}) (g2 : {linear N2 -> O2}).

        Lemma diag_id : diag (\id_M1) (\id_M2) = \id_(pair_lmodType M1 M2).
        Proof.
          rewrite linear_eq.
          apply functional_extensionality=>x/=.
          by rewrite /diag_raw /linID.map -!(lock) -(incl_proj_sum x).
        Qed.

        Lemma diag_comp : (diag g1 g2) \oLin (diag f1 f2) = diag (g1 \oLin f1) (g2 \oLin f2).
        Proof.
          rewrite linear_eq.
          apply functional_extensionality=>x.
          rewrite -!linCompChain=>/=.
          rewrite /diag_raw -!linCompChain=>/=.
          by rewrite addr0 add0r.
        Qed.
      End MorphismsDiagCompositions.
    End Morphisms.

    Module Exports.

      Notation lmodDSPairType := pair_lmodType.
      Infix "\oplus" := (pair_lmodType) (at level 35).
      Notation "\diagmap( f , g )" := (diag f g) (at level 35).
      Notation "\rowmap( f , g )" := (from_ds f g) (at level 35).
      Notation "\colmap( f , g )" := (to_ds f g) (at level 35).
    End Exports.
  End Pair.
  Export Pair.Exports.

  Module Seq.
    Section Ring.
      Variable (R : ringType).
      Section Environment.
        Variable (T : eqType) (I : T -> lmodType R).

        Section Def.
          Definition Nth := (fun L n => match (seq.nth None (map Some L) n) with
          |Some t => I t
          |None => lmodZero.type R
          end).

          Fixpoint DS (L : seq T) : lmodType R := match L with
            |nil => lmodZero.type R
            |a'::L' => (I a') \oplus (DS L')
          end.
        End Def.

        Section Injection.
        Fixpoint incl_raw (L : seq T) (n : nat) {struct n} :
          Nth L n -> DS L
        := match L as LL return Nth LL n -> DS LL with
          |nil => fun _ => tt
          |a::L' => match n as nn return Nth (a::L') nn -> DS (a::L') with
            |0    => fun x => @Pair.incl1 R (I a) (DS L') x
            |S n' => fun x => @Pair.incl2 R (I a) (DS L') ((@incl_raw L' n') x)
            end
          end.

          Lemma incl_lin (L : seq T) (n : nat) : linear (@incl_raw L n).
          Proof. move: n; induction L=>//=. {
            induction n=>//=. }
            move : L IHL; induction n=>//= r x y.
            apply (linearP (@Pair.incl1 _ (I a) (DS L))).
            by rewrite -(linearP (@Pair.incl2 _ (I a) (DS L))) (IHL n).
          Qed.

          Lemma incl_injective
            (L : seq T) (n : nat) : injective (@incl_raw L n).
          Proof. move: n; induction L=>//=.
          { induction n; by move=> x y; destruct x, y. }
            move: L IHL.
            induction n=>/= x y H.
            apply (@Pair.incl1_injective R _ _ x y H).
            apply (IHL n x y (@Pair.incl2_injective R _ _ (@incl_raw L n x) (@incl_raw L n y) H)).
          Qed.
        End Injection.
        Definition incl (L : seq T) (n : nat)
          := Linear (@incl_lin L n).

        Section Projection.
          Fixpoint proj_raw (L : seq T) (n : nat) {struct n} :
          DS L -> Nth L n
        := match L as LL return DS LL -> Nth LL n with
          |nil => match n as nn return lmodZero.type R -> Nth nil nn with
            |0    => fun _ => tt
            |S n' => fun _ => tt
            end
          |a::L' => match n as nn return DS (a::L') -> Nth (a::L') nn with
            |0    => fun x => @Pair.proj1 R (I a) (DS L') x
            |S n' => fun x => (@proj_raw L' n') (@Pair.proj2 R (I a) (DS L') x)
            end
          end.

          Lemma proj_lin (L : seq T) (n : nat) : linear (@proj_raw L n).
          Proof. move: n; induction L=>//. { induction n=>//=. }
            move: L IHL; induction n=>//; move=> r x y.
            by rewrite -(IHL n).
          Qed.
        End Projection.
        Definition proj (L : seq T) (n : nat)
          := Linear (@proj_lin L n).

        Section Results.
          Section Lemmas.
            Variable (L : seq T).
            Lemma nth_cons {a d} {n : nat} : seq.nth d (a::L) (S n) = seq.nth d L n.
            Proof. by induction n. Qed.

            Lemma incl_cons n a x : @incl (a::L) (S n) x = Pair.incl2 (I a) _ (@incl L n x).
            Proof. by []. Qed.

            Lemma proj_cons n a x : @proj (a::L) (S n) (Pair.incl2 (I a) _ x) = @proj L n x.
            Proof. by []. Qed.

            Lemma proj_incl_cons (n n' : nat) a x
            : @proj (a::L) (n.+1) (@incl (a::L) (n'.+1) x) = @proj L n (@incl L n' x).
            Proof. by []. Qed.
          End Lemmas.
          Variable (L : seq T).

          (* The following two lemmas are used for cancellation *)
          Lemma proj_inclK_ofsize (n : 'I_(size L)) x : @proj L (nat_of_ord n) (@incl L (nat_of_ord n) x) = x.
          Proof.
            induction L; destruct n as [n N]=>//.
            induction n=>//; move:x; simpl (Ordinal N : nat)=>x.
            rewrite -ltn_predRL in N.
            by rewrite proj_incl_cons (IHl (Ordinal N)).
          Qed.

          Lemma proj_incl0_ofsize (n n' : 'I_(size L)) x : (nat_of_ord n) != n' -> @proj L n (@incl L n' x) = 0.
          Proof.
            induction L; destruct n as [n N], n' as [n' N']=>//.
            simpl in x, IHl, N, N'=>H.
            induction n; induction n'=>//.
              by (have: proj l n 0 = 0 by rewrite linear0).
            simpl; clear IHn' IHn; move: N' N H;
            rewrite /=eqSS !ltnS=>N' N H.
            by apply (IHl (Ordinal N) (Ordinal N') x H).
          Qed.

          (* The following two lemmas are the same as above but more versitile,
          in that they don't require the index to be an ordinal of size L, simply
          that they are naturals less than size L *)
          Lemma proj_inclK (n : nat) x (M : n < size L) : @proj L n (@incl L n x) = x.
          Proof. apply (@proj_inclK_ofsize (Ordinal M)). Qed.

          Lemma proj_incl0 m1 m2 (n : 'I_m1) (n' : 'I_m2) x (M1 : m1 <= (size L)) (M2 : m2 <= (size L))
            : (nat_of_ord n) != n' -> @proj L n (@incl L n' x) = 0.
          Proof. apply (@proj_incl0_ofsize (widen_ord M1 n) (widen_ord M2 n')). Qed.

          (* this lemma expresses any element as a sum of projections *)
          Lemma incl_proj_sum x : x = \sum_(n < size L) incl L (nat_of_ord n) (@proj L (nat_of_ord n) x).
          Proof.
            induction L.
            by rewrite /size big_ord0; case x.
            destruct x as [Ia DSl].
            by rewrite big_ord_recl {1}(IHl DSl)
            (Pair.incl_proj_sum (Ia, _)) linear_sum.
          Qed.
        End Results.

        (* Given a direct sum indexed by a seq, we define a function to reform
        the direct sum into the direct sum of two smaller direct sums. *)
        Section Operations.
          Variable (L1 L2 : seq T).
          (*Tr = truncate, Ap = Append, R = right, L = left*)
          Section L1.
            Variable (n : 'I_(size L1)).
            Lemma catTrR_eq : (Nth (L1 ++ L2) n) = (Nth L1 n).
            Proof. destruct n as [n' H].
            by rewrite/Nth map_cat nth_cat size_map H. Qed.

            Definition catTrR : (Nth (L1 ++ L2) n) -> (Nth L1 n).
            Proof. by rewrite catTrR_eq. Defined.

            Definition catApR : (Nth L1 n) -> (Nth (L1 ++ L2) n).
            Proof. by rewrite catTrR_eq. Defined.

            Lemma catTrApR_lin : linear catTrR /\ linear catApR.
            Proof. split; rewrite/catTrR/catApR=>r x y; by destruct(catTrR_eq). Qed.

            Lemma catApTrRK : cancel catTrR catApR /\ cancel catApR catTrR.
            Proof. split; rewrite/catApR/catTrR=>x; by destruct(catTrR_eq). Qed.

            Definition catifyL1 : linIsomType (Nth (L1 ++ L2) n) (Nth L1 n)
            := linIsomBuildPack catTrApR_lin catApTrRK.
          End L1.
          Section L2.
            Variable (n : 'I_(size L2)).

            Lemma catTrL_eq : (Nth (L1 ++ L2) (rshift (size L1) n)) = (Nth L2 n).
            Proof. by simpl; rewrite/Nth map_cat nth_cat size_map
            -{2}(addn0 (size L1)) ltn_add2l addnC addnK. Qed.

            Definition catTrL : (Nth (L1 ++ L2) (rshift (size L1) n)) -> (Nth L2 n).
            Proof.  by rewrite catTrL_eq. Defined.

            Definition catApL : (Nth L2 n) -> (Nth (L1 ++ L2) (rshift (size L1) n)).
            Proof. by rewrite catTrL_eq. Defined.

            Lemma catTrApL_lin : linear catTrL /\ linear catApL.
            Proof. split; rewrite/catTrL/catApL=>r x y;by destruct (catTrL_eq). Qed.

            Lemma catApTrLK : cancel catTrL catApL /\ cancel catApL catTrL.
            Proof. split; rewrite/catApL/catTrL=>x; by destruct(catTrL_eq). Qed.

            Definition catifyL2 : linIsomType (Nth (L1 ++ L2) (rshift (size L1) n)) (Nth L2 n)
            := linIsomBuildPack catTrApL_lin catApTrLK.
          End L2.

          Definition split_raw : DS (L1 ++ L2) -> DS L1 \oplus DS L2
            := fun x =>
            (\sum_(n < size L1)(incl L1 n \oLin catifyL1 n \oLin proj (L1 ++ L2) n ) x,
            \sum_(n < size L2)(incl L2 n \oLin catifyL2 n \oLin proj (L1 ++ L2) (rshift (size L1) n)) x).

          Definition unsplit_raw : DS L1 \oplus DS L2 -> DS (L1 ++ L2)
          := fun x =>
            \sum_(n < size L1)((incl (L1 ++ L2) n                     \oLin inv(catifyL1 n) \oLin proj L1 n) x.1) +
            \sum_(n < size L2)((incl (L1 ++ L2) (rshift (size L1) n)  \oLin inv(catifyL2 n) \oLin proj L2 n) x.2).

          Lemma split_lin : linear split_raw.
          Proof. rewrite/split_raw=>r x y/=.
            by rewrite (rwP eqP)/eq_op -(rwP andP) -!(rwP eqP)=>/=;
            rewrite !scaler_sumr -!big_split !(eq_bigr _ (fun i _ => linearP _ _ _ _)).
          Qed.

          Lemma unsplit_lin : linear unsplit_raw.
          Proof. rewrite/unsplit_raw=>r x y/=.
            by rewrite !(eq_bigr _ (fun i _ => linearP _ _ _ _)) !big_split=>/=;
            rewrite -!scaler_sumr scalerDr !addrA (addrC _ (r *: _)) !addrA (addrC (r *: _) (r *: _)).
          Qed.

          Definition split := Linear split_lin.
          Definition unsplit := Linear unsplit_lin.

          Lemma unsplitK : cancel split unsplit.
          Proof. simpl; rewrite /unsplit_raw/split_raw=>x.
            under eq_bigr do rewrite linear_sum.
            under eq_bigr do under eq_bigr do rewrite -!linCompChain.
            under[\sum_(_ < size L2) _] eq_bigr do rewrite linear_sum.
            under[\sum_(_ < size L2) _] eq_bigr do under eq_bigr do rewrite -!linCompChain.
            rewrite!pair_bigA.
            rewrite (eq_bigr (fun p : 'I_(size L1)*'I_(size L1)
            => if p.2 == p.1
              then incl _ p.1 (proj _ p.1 x)
              else 0 ) _).
            rewrite (eq_bigr (fun p : 'I_(size L2)*'I_(size L2)
              => if p.2 == p.1
              then incl _ (rshift (size L1) p.2) (proj _ (rshift (size L1) p.2) x)
              else 0 ) _).
            by rewrite -!big_mkcond !big_pair_diag_eq {3}(@incl_proj_sum _ x)
            size_cat (@big_split_ord _ _ _ (size L1) (size L2)).
            by move=>p _; case (p.2 == p.1) as []eqn:E;
            [move/eqP in E; rewrite E proj_inclK_ofsize (isomlK (catifyL2 p.1)) |
            rewrite proj_incl0_ofsize; [rewrite !linear0|
              rewrite eq_sym/eq_op in E; simpl in E; rewrite E]].
            by move=>p _; case (p.2 == p.1) as []eqn:E;
            [move/eqP in E; rewrite E proj_inclK_ofsize (isomlK (catifyL1 p.1))|
            rewrite proj_incl0_ofsize; [rewrite !linear0|
              rewrite eq_sym/eq_op in E; simpl in E; rewrite E]].
          Qed.

          Lemma splitK : cancel unsplit split.
          Proof. simpl; rewrite /unsplit_raw/split_raw=>x.
          under eq_bigr do rewrite !raddfD.
          under[\sum_(n < _) ((_ \oLin _ \oLin proj _ (rshift _ n)) _)]
            eq_bigr do rewrite !raddfD.

          rewrite !big_split !(eq_bigr _ (fun i _ => linear_sum _ _ _ _)) !pair_bigA.
          rewrite (eq_bigr (fun p : 'I_(size L1)*'I_(size L1)
          => if(p.2 == p.1)
            then incl L1 p.1 (proj L1 p.1 x.1)
            else 0) _).
          rewrite (eq_bigr (fun p : 'I_(size L2)*'I_(size L2)
          => if(p.2 == p.1)
            then incl L2 p.2 (proj L2 p.2 x.2)
            else 0) _).
          {
            destruct x as [x1 x2];
            rewrite -!big_mkcond !big_pair_diag_eq
            (eq_bigr (fun p : 'I_(size L1) => incl _ p (proj _ p x1)) _);[|by move].
            rewrite (eq_bigr (fun p : 'I_(size L2) => incl _ p (proj _ p x2)) _); [| by []].
            rewrite {4}(incl_proj_sum x1) {4}(incl_proj_sum x2) (rwP eqP) /eq_op -(rwP andP).
            split; rewrite -subr_eq0.

            rewrite {1}addrC addrA addNr add0r (eq_bigr (fun _ => 0) _).
            rewrite big_const cardE /iter enumT;
            induction(Finite.enum _)=>//=; by rewrite add0r.

            move =>[[p1 H1] [p2 H2]] _;
            rewrite -!linCompChain proj_incl0;[by rewrite !linear0 |by rewrite size_cat leq_addr|by rewrite size_cat|];
            rewrite -(rwP negP)/not -(rwP eqP)=>/=N;
            by rewrite N -{2}(addn0 (size L1)) ltn_add2l in H1.

            rewrite -addrA addrN addr0 (eq_bigr (fun _ => 0) _).
            rewrite big_const cardE /iter enumT;
            induction(Finite.enum _)=>//=; by rewrite add0r.

            move =>[[p1 H1] [p2 H2]] _;
            rewrite -!linCompChain proj_incl0;[by rewrite !linear0 |by rewrite size_cat|by rewrite size_cat leq_addr|];
            rewrite -(rwP negP)/not -(rwP eqP)=>/=N.
            by rewrite -N -{2}(addn0 (size L1)) ltn_add2l in H2.
          }
          move=>p _; case(p.2 == p.1) as []eqn:E.
          move/eqP in E; rewrite E -!linCompChain.
          rewrite proj_inclK; [by rewrite isomKl|].
          destruct p as [[p1 H1] [p2 H2]].
          by rewrite size_cat ltn_add2l.
          rewrite -!linCompChain proj_incl0; [by rewrite !linear0|by rewrite size_cat|by rewrite size_cat|].
          rewrite /eq_op in E; simpl in E.
          by rewrite /rshift eqn_add2l eq_sym E.

          move=>p _; case(p.2 == p.1) as []eqn:E.
          move/eqP in E; rewrite -E -!linCompChain.
          rewrite proj_inclK; [by rewrite isomKl|].
          destruct p as [[p1 H1] [p2 H2]]=>/=.
          by rewrite size_cat addnC (ltn_addl _ H2).
          rewrite -!linCompChain proj_incl0; [by rewrite !linear0|by rewrite size_cat leq_addr|by rewrite size_cat leq_addr|].
          rewrite /eq_op in E; simpl in E.
          by rewrite eq_sym E.
          Qed.
        End Operations.
      End Environment.

      Section Hom.
        Variable (S T : eqType) (I : T -> lmodType R) (T_S : S -> T).

        Fixpoint homify_raw (L : seq S) : DS (I \o T_S) L -> DS I (map T_S L)
          := match L with
          |nil => id
          |a::l => fun x => (x.1 , homify_raw x.2)
          end.
        Fixpoint unhomify_raw (L : seq S) : DS I (map T_S L) -> DS (I \o T_S) L
          := match L with
          |nil => id
          |a::l => fun x => (x.1 , unhomify_raw x.2)
          end.

        Variable (L : seq S).
        Lemma homify_lin : linear (@homify_raw L) /\ linear (@unhomify_raw L).
        Proof. split; induction L=>//=r x y;
          by rewrite IHl/homify_raw/unhomify_raw.
        Qed.
        Lemma homifyK : cancel (@homify_raw L) (@unhomify_raw L) /\ cancel (@unhomify_raw L) (@homify_raw L).
        Proof. split; induction L=>//=x; destruct x;
          by rewrite IHl.
        Qed.
        Definition homify := linIsomBuildPack homify_lin homifyK.
      End Hom.

      Section Bijection.
        Variable (S T : eqType) (I : T -> lmodType R)
            (T_S : S -> T) (S_T : T -> S) (Inj : cancel S_T T_S).

        Variable (L : seq T).
        Definition mapify_raw : DS I (map T_S (map S_T L)) -> DS I L.
        by rewrite mapK. Defined.
        Definition unmapify_raw : DS I L -> DS I (map T_S (map S_T L)).
        by rewrite mapK. Defined.
        Lemma mapify_lin : linear mapify_raw /\ linear unmapify_raw.
        Proof. split; by rewrite/mapify_raw/unmapify_raw; destruct mapK. Qed.
        Lemma mapifyK : cancel mapify_raw unmapify_raw /\ cancel unmapify_raw mapify_raw.
        Proof. split; by rewrite/mapify_raw/unmapify_raw; destruct mapK. Qed.
        Definition mapify := linIsomBuildPack mapify_lin mapifyK.

        Definition bijectify := linIsomConcat (homify I T_S (map S_T L)) mapify.
      End Bijection.
    End Ring.
  End Seq.

  Section General.
    Variable (R : ringType).
    Section Def.
      Variable (F : finType) (I : F -> lmodType R).

      Definition DS : lmodType R := Seq.DS I (enum F).

      Section Components.
        Variable (f : F).

        Lemma cardElt : nat_of_ord (enum_rank f) < size (enum F).
        Proof. rewrite -cardE; apply ltn_ord. Qed.

        Definition Ord := Ordinal cardElt.
        Definition Nth := Seq.Nth I (enum F) Ord.

        Section TypeConversion.
          Lemma Nth_If_eq : Nth = I f.
          Proof. by rewrite /Nth/Seq.Nth -codomE nth_codom enum_rankK. Qed.
          Lemma If_Nth_eq : I f = Nth.
          Proof. by rewrite Nth_If_eq. Qed.

          Definition finify_raw : Nth -> I f := (fun fn : Nth
            -> Nth => eq_rect_r (fun M : lmodType R => Nth -> M)
              fn If_Nth_eq) id.
          Definition unfinify_raw : I f -> Nth := (fun fn : Nth
            -> Nth => eq_rect_r (fun M : lmodType R => M -> Nth)
              fn If_Nth_eq) id.
          Lemma finify_lin : linear finify_raw /\ linear unfinify_raw.
          Proof. split; by rewrite /finify_raw/unfinify_raw=>r x y; destruct If_Nth_eq. Qed.
          Lemma finifyK : cancel finify_raw unfinify_raw /\ cancel unfinify_raw finify_raw.
          Proof. split; by rewrite/finify_raw/unfinify_raw; destruct If_Nth_eq. Qed.

          Definition finify := linIsomBuildPack finify_lin finifyK.

        End TypeConversion.

        Section Projection.
          Definition proj_raw : DS -> I f
          := finify \oLin (@Seq.proj R F I (enum F) Ord).

          Lemma proj_lin : linear proj_raw.
          Proof. rewrite/proj_raw=> r x y; by rewrite !linearPZ. Qed.

          Definition proj : {linear DS -> I f} := Linear proj_lin.
        End Projection.

        Section Injection.
          Definition incl_raw : I f -> DS
          := (@Seq.incl R F I (enum F) Ord) \oLin inv(finify).

          Lemma incl_lin : linear incl_raw.
          Proof. rewrite/incl_raw=> r x y; by rewrite !linearPZ. Qed.

          Lemma incl_injective : injective incl_raw.
          Proof. rewrite/incl_raw=>x y; rewrite -!linCompChain=>H.
            apply Seq.incl_injective in H.
            apply (congr1 finify) in H.
            by rewrite !isomKl in H.
          Qed.

          Definition incl : {linear I f -> DS} := Linear incl_lin.
        End Injection.
      End Components.

      Section Results.
        Lemma proj_inclK (f : F) x : proj f (incl f x) = x.
        Proof. by rewrite /proj_raw/incl_raw -!linCompChain
          Seq.proj_inclK; [rewrite -{2}(isomKf (finify f) x) | apply cardElt].
        Qed.

        Lemma proj_incl0 (f f' : F) x : f != f' -> @proj f (@incl f' x) = 0.
        Proof.
          rewrite/proj_raw/incl_raw-!linCompChain.
          case(enum_rank f != enum_rank f') as []eqn:E.
          by rewrite (@Seq.proj_incl0_ofsize _ _ _ _ (Ord f) (Ord f') _ E) linear0.
          move/negbFE/eqP/enum_rank_inj/eqP in E.
          by rewrite E.
        Qed.

        Lemma incl_proj_sum x : x = \sum_(f : F) incl f (proj f x).
        Proof.
          rewrite big_enum_val {1}(Seq.incl_proj_sum x) -!big_enum -cardT.
          refine (eq_bigr _ _).
          move=> i _; rewrite /incl_raw/proj_raw/Seq.incl/Seq.proj
          -!linCompChain (isomlK (finify _))/Ord=>/=.
          by rewrite enum_valK.
        Qed.

        Lemma inj_proj_idem x : \sum_(f : F) incl f (proj f (\sum_(f : F) incl f (proj f x))) = \sum_(f : F) incl f (proj f x).
        Proof. by rewrite -incl_proj_sum. Qed.
      End Results.
    End Def.

    Section Operations.
      Variable (F G : finType) (I : F + G -> lmodType R).
      Definition J : F -> lmodType R := I \o inl.
      Definition K : G -> lmodType R := I \o inr.

      Lemma sumify_eq : (enum (sum_finType F G)) = ((map inl (enum F)) ++ (map inr (enum G))).
      Proof. by rewrite/DS enumT(unlock _)/=/sum_enum -!enumT. Qed.

      Definition sumify_raw : DS I -> Seq.DS I ((map inl (enum F)) ++ (map inr (enum G))).
      by rewrite /DS sumify_eq. Defined.
      Definition unsumify_raw : Seq.DS I ((map inl (enum F)) ++ (map inr (enum G))) -> DS I.
      by rewrite /DS sumify_eq. Defined.

      Lemma sumify_lin : linear sumify_raw /\ linear unsumify_raw.
        Proof. split; rewrite/sumify_raw/unsumify_raw=>r x y;
        by destruct sumify_eq. Qed.
      Lemma sumifyK : cancel sumify_raw unsumify_raw /\ cancel unsumify_raw sumify_raw.
        Proof. split; rewrite/sumify_raw/unsumify_raw=>x;
        by destruct sumify_eq. Qed.
	    Definition sumify := linIsomBuildPack sumify_lin sumifyK.

      Definition split : DS I -> DS J \oplus DS K
       := \diagmap(inv(Seq.homify _ inl _), inv(Seq.homify _ inr _))
			      \oLin (Seq.split I _ _) \oLin sumify.

      Definition unsplit : {linear DS J \oplus DS K -> DS I}
      := inv(sumify) \oLin (Seq.unsplit I _ _) \oLin
          \diagmap(Seq.homify _ inl _, Seq.homify _ inr _).

      Lemma unsplitK : cancel split unsplit.
      Proof. rewrite /unsplit/split=>x.
        by rewrite -!linCompChain (linCompChain (\diagmap(_,_)) (\diagmap(_,_)))
        Pair.diag_comp !linIsom.concatKl Pair.diag_id -linIDChain
        Seq.unsplitK (isomlK sumify).
      Qed.

      Lemma splitK : cancel unsplit split.
      Proof. rewrite /unsplit/split=>x.
        by rewrite -!linCompChain isomKl Seq.splitK
        (linCompChain (\diagmap(_,_)) (\diagmap(_,_)))
        Pair.diag_comp !linIsom.concatlK Pair.diag_id -linIDChain.
      Qed.

    End Operations.

  End General.
  Section Results.
    Variable (R : ringType) (M N : lmodType R) (m : M) (n : N).
    Lemma pair_eq_seq (F G : eqType) (f : F -> M) (g : G -> N)
      (L1 : seq F) (L2 : seq G) :
      \sum_(i <- L1) (f i, 0)%R + \sum_(i <- L2) (0, g i) == (m,n)
      <-> (\sum_(i <- L1) f i == m /\ \sum_(i <- L2) g i == n).
    Proof. split; [move=> H|move=> [H1 H2]]. {
        have:(\sum_(i <- L1) (dsLmod.Pair.incl1 M N (f i)) + \sum_(i <- L2) (dsLmod.Pair.incl2 M N (g i)) == (m, n))
          by apply H .
        rewrite -!raddf_sum/Pair.incl1/Pair.incl2/(@add _)/=
        /add_pair add0r addr0 -(rwP eqP)=>H0;
        by inversion H0.
      }
      move: H1 H2; rewrite -!(rwP eqP)=>H1 H2.
      have:(\sum_(i <- L1) (Pair.incl1 _ _  (f i)) == (m, @zero N))
        by rewrite -raddf_sum/Pair.incl1 H1.
      have:(\sum_(i <- L2) (Pair.incl2 _ _ (g i)) == (@zero M, n))
        by rewrite -raddf_sum/Pair.incl2 H2=>/=.
      rewrite -!(rwP eqP)=>H H0.
      have:(\sum_(i <- L1) (dsLmod.Pair.incl1 _ _ (f i)) + \sum_(i <- L2) (dsLmod.Pair.incl2 _ _ (g i)) == (m, n))
        by rewrite H H0 {1}/(@add (pair_lmodType M N))/=
        /add_pair add0r addr0.
      by rewrite /Pair.incl1/Pair.incl2 -(rwP eqP).
    Qed.

    Lemma pair_eq (F G : finType) (f : F -> M) (g : G -> N) :
      \sum_i (f i, 0)%R + \sum_i (0, g i) == (m,n)
      <-> (\sum_i f i == m /\ \sum_i g i == n).
    Proof. by rewrite -big_enum/=pair_eq_seq big_enum/=. Qed.
  End Results.
End dsLmod.

Export dsLmod.Pair.Exports.
Notation "\bigoplus_ i F" := (dsLmod.DS (fun i => F i)) : lmod_scope.
Notation "\bigoplus F" := (dsLmod.DS F) : lmod_scope.
Notation "\bigoplus_ ( i : t ) F" := (dsLmod.DS (fun i : t => F i)) : lmod_scope.
Notation "\bigoplus_ ( i 'in' A ) F" := (dsLmod.Seq.DS (filter F (fun i => i \in A))) : lmod_scope.
Notation "\proj^( I )_ f " := (dsLmod.proj I f ) : lmod_scope.
Notation "\incl^( I )_ f " := (dsLmod.incl I f ) : lmod_scope.
Notation "\proj_ f ^( I )" := (dsLmod.proj I f ) : lmod_scope.
Notation "\incl_ f ^( I )" := (dsLmod.incl I f ) : lmod_scope.

Theorem DirectSum_UniversalProperty (R : ringType) (F : finType)
  (I : F -> (lmodType R))
    : forall (f : forall i : F, {linear \bigoplus I -> (I i)}),
      exists (g : forall i : F, {linear (I i) -> (I i)}),
        forall i : F, f i \oLin \incl_i^(I) = g i.
Proof. move=> f.
  by refine(ex_intro _ (fun i => f i \oLin \incl_i^(I)) _ ).
Qed.

Close Scope  lmod_scope.
Close Scope  ring_scope.


Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Semantics.
Require Import coqutil.Word.Interface.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Coq.Lists.List.
Require Import Implementations.SOS.SOSReduction.

Section word.

Context {p : Types.parameters}
        {ok : Types.ok}.
        Existing Instance semantics_ok.

Local Notation ws := word_size_in_bytes.

Notation N aw := (word.add (word.of_Z ws) aw).
Local Coercion Z.of_nat : nat >-> Z.

Add Ring Wring : Word.Properties.word.ring_theory.

Lemma word_add_0' : forall (a : Semantics.word), word.add a (word.of_Z (0)) = a.
Proof.
  intros. ring.
Qed.

Lemma word_add_0 : forall (a : Semantics.word), word.add a (word.of_Z (0 * ws)) = a.
Proof.
  intros. assert (0 = 0 * ws) by auto. rewrite <- H. ring.
Qed.

Lemma word_add_assoc (a : Semantics.word) b c : word.add a (word.add b c) = word.add (word.add a b) c.
Proof.
    ring.
Qed.

Lemma word_add_comm (a b : Semantics.word) : word.add a b = word.add b a.
Proof.
    ring.
Qed.

Lemma next_word' (a : Semantics.word) n : word.add a (word.of_Z (n)) = N (word.add a (word.of_Z (n - ws))).
Proof.
    ring_simplify.
    rewrite <- word_add_assoc.
    rewrite <- Properties.word.ring_morph_add. assert (ws + (n - ws)= n) by auto with zarith.
    rewrite H. auto.
Qed.

End word.