(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to the
   correctness of simplification  algorithms for context-free grammars,
   namely empty rules elimination, unit rules elimination, useless symbol
   elimination and inaccessible symbol elimination.
   More information can be found in the paper "Formalization of
   simplification for context-free grammars", LSFA 2015.
   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS                                      *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - DEFINITIONS                        *)
(* --------------------------------------------------------------------- *)

Section Useless.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

Definition useful (g: cfg _ _) (s: non_terminal + terminal): Prop:=
match s with
| inr t => True
| inl n => exists s: sentence, derives g [inl n] (map term_lift s)
end.

Definition useful_sf (g: cfg _ _)(l: _): Prop:=
forall s: _,
In s l -> useful g s.

Inductive g_use_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_use : forall left: non_terminal,
             forall right: sf,
             rules g left right ->
             useful g (inl left) ->
             useful_sf g right ->
             g_use_rules g left right.

Lemma g_use_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_use_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [ tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- intros left right H2.
  inversion H2.
  subst.
  destruct H1 as [_ H1].
  specialize (H1 left right H).
  destruct H1 as [H4 [H5 H6]].
  split.
  + exact H4.
  + split.
    * exact H5.
    * exact H6.
Qed.

Definition g_use (g: cfg _ _): cfg _ _:= {|
start_symbol:= start_symbol g;
rules:= g_use_rules g;
rules_finite:= g_use_finite g
|}.

Definition has_no_useless_symbols (g: cfg _ _): Prop:=
forall n: _, appears g (inl n) -> useful g (inl n).

Definition non_empty (g: cfg _ _): Prop:=
useful g (inl (start_symbol g)).

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - LEMMAS AND THEOREMS                *)
(* --------------------------------------------------------------------- *)

Lemma useful_exists:
forall g: cfg _ _,
forall n:non_terminal,
useful g (inl n) ->
exists (left : non_terminal) (right : sf),
rules g left right /\ (n = left \/ In (inl n) right).
Proof.
intros g n H1.
destruct H1 as [s H2].
apply exists_rule in H2.
destruct H2 as [H2 | H2].
- exists n, (map term_lift s).
  split.
  + exact H2.
  + left.
    reflexivity.
- destruct H2 as [right [H3 H4]].
  exists n, right.
  split.
  + exact H3.
  + left.
    reflexivity.
Qed.

Lemma useful_sf_sentence:
forall l: sf,
forall g: cfg _ _,
useful_sf g l -> exists s': sentence, derives g l (map term_lift s').
Proof.
intros l g H.
induction l.
- exists [].
  simpl.
  apply derives_refl.
- replace (a :: l) with ([a]++l) in H.
  + assert (H1: forall s: non_terminal + terminal, In s l -> useful g s).
      {
      intros s H1.
      specialize (H s).
      apply H.
      apply in_or_app.
      right.
      exact H1.
      }
    specialize (IHl H1).
    assert (H2: useful g a).
      {
      apply H.
      simpl.
      left.
      reflexivity.
      }
    unfold useful in H2.
    destruct a.
    * destruct IHl as [s' H3].
      destruct H2 as [s H2].
      exists (s ++ s').
      simpl.
      {
      rewrite map_app.
      change (inl n :: l) with ([inl n] ++ l).
      apply derives_combine.
      split.
      - exact H2.
      - exact H3.
      }
    * destruct IHl as [s2 H5].
      exists ([t] ++ s2).
      rewrite map_app.
      change (inr t :: l) with ([inr t] ++ l).
      apply derives_combine.
      {
      split.
      - simpl.
        constructor.
      - exact H5.
      }
  + simpl.
    reflexivity.
Qed.

Lemma use_step:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules g left right ->
(forall s: non_terminal + terminal, In s right -> useful g s) ->
useful g (inl left).
Proof.
intros g left right H1 H2.
unfold useful.
apply derives_rule with (s1:=[]) (s2:=[]) in H1.
simpl in H1.
rewrite app_nil_r in H1.
apply useful_sf_sentence in H2.
destruct H2 as [s' H3].
exists s'.
apply derives_trans with (s2:=right).
- exact H1.
- exact H3.
Qed.

Lemma useful_g_g_use:
forall g: cfg _ _,
forall n: non_terminal,
useful g (inl n) -> useful (g_use g) (inl n).
Proof.
intros g n H.
unfold useful in H.
destruct H as [x H].
unfold useful.
exists x.
apply derives_sflist in H.
apply derives_sflist.
destruct H as [l [H2 [H3 H4]]].
exists l.
split.
- assert (H5: length l >= 2 \/ length l < 2).
    {
    omega.
    }
  destruct H5 as [H5 | H5].
  + assert (H6:= H5).
    apply sflist_rules with (g:=g) in H5.
    destruct H5 as [H5 _].
    specialize (H5 H2).
    apply sflist_rules.
    * exact H6.
    * intros i H7.
      specialize (H5 i H7).
      destruct H5 as [left [right [s0 [s' [H10 [H11 H12]]]]]].
      exists left, right, s0, s'.
      {
      split.
      - exact H10.
      - split.
        + exact H11.
        + simpl.
          apply Lift_use.
          * exact H12.
          * unfold useful.
            assert (H20: derives g (s0 ++ inl left :: s') (map term_lift x)).
              {
              apply derives_sflist.
              rewrite <- (firstn_skipn i l) in H2.
              apply sflist_app_l in H2.
              exists (skipn i l).
              split.
              - exact H2.
              - split.
                + rewrite hd_skip.
                  exact H10.
                + rewrite last_skip.
                  * exact H4.
                  * omega.
              }
            assert (H21: exists s'': sentence, derives g [inl left] (map term_lift s'')).
              {
              apply derives_split in H20.
              destruct H20 as [s1' [s2' [H21 [_ H22]]]].
              replace (inl left :: s') with ([inl left] ++ s') in H22.
              - apply derives_split in H22.
                destruct H22 as [s1'0 [s2'0 [H31 [H32 _]]]].
                symmetry in H21.
                apply map_expand in H21.
                destruct H21 as [s1'' [s2'' [H40 [H41 H42]]]].
                rewrite <- H42 in H31.
                symmetry in H31.
                apply map_expand in H31.
                destruct H31 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H32.
                exists s1'''.
                exact H32.
              - simpl.
                reflexivity.
              }
            exact H21.
          * intros s1 H8.
            {
            destruct s1.
            - assert (H30: derives g (s0 ++ right ++ s') (map term_lift x)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H2.
                apply sflist_app_l in H2.
                exists (skipn (S i) l).
                split.
                - exact H2.
                - split.
                  + rewrite <- H11.
                    apply hd_skip.
                  + rewrite <- H4.
                    apply last_skip.
                    omega.
                }
              assert (H31: exists s'': sentence, derives g right (map term_lift s'')).
                {
                apply derives_split in H30.
                destruct H30 as [s1' [s2' [H35 [H36 H37]]]].
                apply derives_split in H37.
                destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                rewrite <- H43 in H38.
                symmetry in H38.
                apply map_expand in H38.
                destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H39.
                exists s1'''.
                exact H39.
                }
              assert (H32: exists s'': sentence, derives g [inl n0] (map term_lift s'')).
                {
                apply in_split in H8.
                destruct H8 as [l1 [l2 H60]].
                rewrite H60 in H31.
                destruct H31 as [s'' H61].
                apply derives_split in H61.
                destruct H61 as [s1' [s2' [H35 [H36 H37]]]].
                replace (inl n0 :: l2) with ([inl n0] ++ l2) in H37.
                - apply derives_split in H37.
                  destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                  symmetry in H35.
                  apply map_expand in H35.
                  destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                  rewrite <- H43 in H38.
                  symmetry in H38.
                  apply map_expand in H38.
                  destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                  rewrite <- H51 in H39.
                  exists s1'''.
                  exact H39.
                - simpl.
                  reflexivity.
                }
              exact H32.
            - simpl.
              auto.
          }
      }
  + destruct l as [|s0 l].
    * apply sflist_empty.
    * {
      destruct l as [|s1 l].
      - apply sflist_start.
      - replace (s0 :: s1 :: l) with ([s0] ++ [s1] ++ l) in H5.
        + repeat rewrite app_length in H5.
          simpl in H5.
          repeat apply lt_S_n in H5.
          apply lt_n_0 in H5.
          contradiction.
        + simpl.
          reflexivity.
      }
- split.
  + exact H3.
  + exact H4.
Qed.

Lemma useful_g_use:
forall g: cfg _ _,
forall n: non_terminal,
appears (g_use g) (inl n) -> useful (g_use g) (inl n).
Proof.
intros g n H.
inversion H.
clear H.
destruct H0 as [right [H1 H2]].
destruct H2 as [H2| H2].
- subst.
  simpl in H1.
  inversion H1.
  subst.
  apply useful_g_g_use.
  exact H0.
- simpl in H1.
  inversion H1.
  subst.
  apply useful_g_g_use.
  specialize (H3 (inl n)).
  apply H3.
  exact H2.
Qed.

Lemma sflist_g_use_g:
forall g: cfg _ _,
forall l: list sf,
sflist (g_use g) l -> sflist g l.
Proof.
intros g l H.
induction H.
- apply sflist_empty.
- apply sflist_start.
- apply sflist_step with (left:=left).
  exact IHsflist.
  exact H0.
  simpl in H1.
  inversion H1.
  exact H2.
Qed.

Lemma produces_g_use_g:
forall g: cfg _ _,
forall s: sentence,
produces (g_use g) s -> produces g s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
simpl in H2.
apply derives_sflist.
exists l.
split.
- apply sflist_g_use_g.
  exact H1.
- split.
  + exact H2.
  + exact H3.
Qed.

Lemma sflist_g_g_use:
forall g: cfg _ _,
forall l: list sf,
forall s: sentence,
sflist g l /\ last l [] = map term_lift s -> sflist (g_use g) l.
Proof.
intros g l s [H1 H2].
assert (H3: length l >= 2 \/ length l < 2).
  {
  omega.
  }
destruct H3 as [H3 | H3].
- assert (H3':=H3).
  apply sflist_rules with (g:=g) in H3.
  destruct H3 as [H3 _].
  specialize (H3 H1).
  apply sflist_rules.
  + exact H3'.
  + intros i H4.
    specialize (H3 i H4).
    destruct H3 as [left [right [s0 [s' [H5 [H6 H7]]]]]].
    exists left, right, s0, s'.
    split.
    * exact H5.
    * {
      split.
      - exact H6.
      - simpl.
        apply Lift_use.
        + exact H7.
        + unfold useful.
          assert (H20: derives g (s0 ++ inl left :: s') (map term_lift s)).
            {
            apply derives_sflist.
            rewrite <- (firstn_skipn i l) in H1.
            apply sflist_app_l in H1.
            exists (skipn i l).
            split.
            - exact H1.
            - split.
              + rewrite hd_skip.
                exact H5.
              + rewrite last_skip.
                * exact H2.
                * omega.
            }
          assert (H21: exists s'': sentence, derives g [inl left] (map term_lift s'')).
            {
            apply derives_split in H20.
            destruct H20 as [s1' [s2' [H21 [_ H22]]]].
            replace (inl left :: s') with ([inl left] ++ s') in H22.
            - apply derives_split in H22.
              destruct H22 as [s1'0 [s2'0 [H31 [H32 _]]]].
              symmetry in H21.
              apply map_expand in H21.
              destruct H21 as [s1'' [s2'' [H40 [H41 H42]]]].
              rewrite <- H42 in H31.
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [s1''' [s2''' [H50 [H51 H52]]]].
              rewrite <- H51 in H32.
              exists s1'''.
              exact H32.
            - simpl.
              reflexivity.
            }
          exact H21.
        + intros s1 H99.
          destruct s1.
          * assert (H30: derives g (s0 ++ right ++ s') (map term_lift s)).
              {
              apply derives_sflist.
              rewrite <- (firstn_skipn (S i) l) in H1.
              apply sflist_app_l in H1.
              exists (skipn (S i) l).
                split.
              - exact H1.
              - split.
                + rewrite <- H6.
                  apply hd_skip.
                + rewrite <- H2.
                  apply last_skip.
                  omega.
              }
            assert (H31: exists s'': sentence, derives g right (map term_lift s'')).
              {
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H35 [H36 H37]]]].
              apply derives_split in H37.
              destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
              symmetry in H35.
              apply map_expand in H35.
              destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
              rewrite <- H43 in H38.
              symmetry in H38.
              apply map_expand in H38.
              destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
              rewrite <- H51 in H39.
              exists s1'''.
              exact H39.
              }
            assert (H32: exists s'': sentence, derives g [inl n] (map term_lift s'')).
              {
              apply in_split in H99.
              destruct H99 as [l1 [l2 H60]].
              rewrite H60 in H31.
              destruct H31 as [s'' H61].
              apply derives_split in H61.
              destruct H61 as [s1' [s2' [H35 [H36 H37]]]].
              replace (inl n :: l2) with ([inl n] ++ l2) in H37.
              - apply derives_split in H37.
                destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                rewrite <- H43 in H38.
                symmetry in H38.
                apply map_expand in H38.
                destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H39.
                exists s1'''.
                exact H39.
              - simpl.
                reflexivity.
              }
            unfold useful.
            exact H32.
          * simpl.
            auto.
      }
- destruct l as [|s0 l].
  + apply sflist_empty.
  + destruct l as [|s1 l].
    * apply sflist_start.
    * {
      replace (s0 :: s1 :: l) with ([s0] ++ [s1] ++ l) in H3.
      - repeat rewrite app_length in H3.
        simpl in H3.
        repeat apply lt_S_n in H3.
        apply lt_n_0 in H3.
        contradiction.
      - simpl.
        reflexivity.
      }
Qed.

Lemma produces_g_g_use:
forall g: cfg _ _,
forall s: sentence,
produces g s -> produces (g_use g) s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
apply derives_sflist.
exists l.
split.
- apply sflist_g_g_use with (s:=s).
  split.
  + exact H1.
  + exact H3.
- split.
  + exact H2.
  + exact H3.
Qed.

Theorem g_equiv_use:
forall g: cfg _ _,
non_empty g -> g_equiv (g_use g) g.
Proof.
unfold g_equiv.
intros g H' s.
split.
- apply produces_g_use_g.
- apply produces_g_g_use.
Qed.

Theorem g_use_correct:
forall g: cfg _ _,
non_empty g ->
g_equiv (g_use g) g /\
has_no_useless_symbols (g_use g).
Proof.
intros g H'.
split.
- apply g_equiv_use.
  exact H'.
- unfold has_no_useless_symbols.
  intros n H.
  inversion H.
  destruct H0 as [right [H1 H2]].
  simpl in H1.
  inversion H1.
  subst.
  destruct H2.
  + subst.
    apply useful_g_g_use in H3.
    exact H3.
  + specialize (H4 (inl n) H2).
    apply useful_g_g_use in H4.
    exact H4.
Qed.

End Useless.


(*** Error bounds for matrix vector multiplication
     from the error bounds for dot product
***)

From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.
From mathcomp Require Import all_ssreflect ssralg all_algebra seq matrix.
From mathcomp.analysis Require Import Rstruct.
From Iterative Require Import dot_prod_defn generalize float_model_generic
               inf_norm_properties lemmas.

Import Coq.Lists.List Coq.Lists.List.ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify
                            Float_notations Automate.
Set Bullet Behavior "Strict Subproofs".

(*** ||A \otimes v - A v|| <= max_i {e_i}
     |A_i \otimes v - A_i v_2| <= e_i
***)
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Section WITHNANS.
Context {NANS: Nans}.

Definition e_i {n:nat} (i : 'I_n.+1)
  (A: 'M[ftype Tsingle]_n.+1) (v: 'cV[ftype Tsingle]_n.+1) :=
  let l1 := vec_to_list_float n.+1 (\row_(j < n.+1) A i j)^T in
  let l2 := vec_to_list_float n.+1 v in
  let L := combine l1 l2 in
  let rs := dot_prodR (Flist_to_Rlist_pair_abs L) in
  let e := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let d := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  let nr := INR n.+1 in
  (rs * ((1 + d)^n.+1 -1) + nr * e * (1+d)^(n.+1 -1)%coq_nat +
  e * ((1+d)^(n.+1-1)%coq_nat -1) / d)%Re.

Definition mat_vec_mult_err_bnd {n:nat}
 (A: 'M[ftype Tsingle]_n.+1) (v: 'cV[ftype Tsingle]_n.+1):=
 bigmaxr 0%Re [seq (e_i i A v) | i <- enum 'I_n.+1].

Definition FT2R_mat {m n: nat} (A : 'M[ftype Tsingle]_(m.+1, n.+1)) :
   'M[R]_(m.+1, n.+1):=
  \matrix_(i, j) FT2R (A i j).

Notation "A +f B" := (addmx_float A B) (at level 80).
Notation "-f A" := (opp_mat A) (at level 50).
Notation "A *f B" := (mulmx_float A B) (at level 70).

(** an equivalence between real dot product defined using the mathcomp
    sum and our dot product definition using the lists
**)

Lemma sum_dot {n:nat} (m:nat) {ty} (le_n_m : (m <= n.+1)%nat) :
  forall (v1 v2: 'cV[ftype ty]_n.+1),
  let l1 := @vec_to_list_float _ n m v1 in
  let l2 := @vec_to_list_float _ n m v2 in
  let L := combine l1 l2 in
  \sum_(j < m) (FT2R (v1 (@widen_ord m n.+1 le_n_m j) 0) *
                FT2R (v2 (@widen_ord m n.+1 le_n_m j) 0)) =
  dot_prodR (Flist_to_Rlist_pair L).
Proof.
intros.
induction m.
+  rewrite big_ord0 //=.
+ simpl. rewrite big_ord_recr //=.
  assert (dot_prodR
            ((FT2R (v1 (inord m) ord0),
              FT2R (v2 (inord m) ord0))
             :: Flist_to_Rlist_pair
                  (combine (vec_to_list_float m v1)
                     (vec_to_list_float m v2))) =
          (FT2R (v1 (inord m) ord0) *
              FT2R (v2 (inord m) ord0)) +
          dot_prodR (Flist_to_Rlist_pair
                      (combine (vec_to_list_float m v1)
                       (vec_to_list_float m v2)))).
  { by unfold dot_prodR. } rewrite H. clear H.
  assert (\sum_(i < m)
             FT2R (v1
                  (widen_ord (m:=n.+1) le_n_m
                     (widen_ord (m:=m.+1) (leqnSn m) i)) 0) *
               FT2R
                 (v2
                    (widen_ord (m:=n.+1) le_n_m
                       (widen_ord (m:=m.+1) (leqnSn m) i)) 0) =
           dot_prodR
            (Flist_to_Rlist_pair
               (combine (vec_to_list_float m v1)
                  (vec_to_list_float m v2)))).
  { unfold L in IHm.
    assert ((m <= n.+1)%nat). { by apply ltnW. }
    specialize (IHm H). rewrite -IHm.
    apply eq_big. by [].
    intros.
    assert ((widen_ord (m:=n.+1) le_n_m
                  (widen_ord (m:=m.+1) (leqnSn m) i))=
             (widen_ord (m:=n.+1) H i)).
    { unfold widen_ord.
      apply val_inj. by simpl.
    } by rewrite H1.
  } rewrite H. rewrite addrC.
  assert ((widen_ord (m:=n.+1) le_n_m ord_max) = (inord m)).
  { unfold widen_ord.
    apply val_inj. simpl. by rewrite inordK.
  } by rewrite H0.
Qed.

Lemma length_veclist {ty} {n m:nat} (v: 'cV[ftype ty]_n.+1):
  length (@vec_to_list_float _ n m v) = m.
Proof.
induction m.
+ simpl. auto.
+ simpl. by rewrite IHm.
Qed.

(***  Bound for matrix vector multiplication from the bound for
      dot product of vectors
***)

Lemma mat_vec_err_bnd_holds {n:nat}:
  forall (A: 'M[ftype Tsingle]_n.+1) (v: 'cV[ftype Tsingle]_n.+1),
  (1 < n.+1 /\ n.+1< (Z.to_nat (Z.pow_pos 2 23) - 1)%coq_nat)%coq_nat ->
  let e := / 2 * Raux.bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle) in
  let d := / 2 * Raux.bpow Zaux.radix2 (- fprec Tsingle + 1) in
  let nr := INR n.+1 in
  (forall i:nat, (i < n.+1)%nat ->
    (forall a b : ftype Tsingle,
      In (a, b)
        (combine (vec_to_list_float n.+1 (\row_j A (inord i) j)^T)
           (vec_to_list_float n.+1 v)) ->
      is_finite (fprec Tsingle) (femax Tsingle) a = true /\
      is_finite (fprec Tsingle) (femax Tsingle) b = true /\
      (Rabs (FT2R a) <=
       sqrt (F' / ((nr+1) * (1 + d) ^ (n.+1 + 1)%coq_nat) - e))%Re /\
      (Rabs (FT2R b) <=
       sqrt (F' / ((nr+1) * (1 + d) ^ (n.+1 + 1)%coq_nat) - e))%Re))->
  vec_inf_norm (FT2R_mat (A *f v) - (FT2R_mat A) *m (FT2R_mat v)) <=
  mat_vec_mult_err_bnd A v.
Proof.
intros. unfold vec_inf_norm, mat_vec_mult_err_bnd.
apply /RleP. apply bigmax_le; first by rewrite size_map size_enum_ord.
intros. rewrite seq_equiv.
rewrite nth_mkseq; last by rewrite size_map size_enum_ord in H1.
pose proof (forward_error_dot_aux ((combine
          (vec_to_list_float n.+1
             (\row_j A (inord i) j)^T)
          (vec_to_list_float n.+1 v)))).
assert (length (combine
            (vec_to_list_float n.+1 (\row_j A (inord i) j)^T)
            (vec_to_list_float n.+1 v)) = n.+1).
{ rewrite combine_length. rewrite !length_veclist. lia. }
rewrite H3 in H2.
assert ((1 < n.+1)%coq_nat). { destruct H. apply H. }
assert ((n.+1 < (Z.to_nat (Z.pow_pos 2 23) - 1)%coq_nat)%coq_nat).
{ destruct H. apply H5. } specialize (H2 H4 H5).
assert (forall a b : ftype Tsingle,
      In (a, b)
        (combine
           (vec_to_list_float n.+1
              (\row_j A (inord i) j)^T)
           (vec_to_list_float n.+1 v)) ->
      is_finite (fprec Tsingle)  (femax Tsingle) a = true /\
      is_finite (fprec Tsingle)  (femax Tsingle) b = true /\
      (Rabs (FT2R a) <=
       sqrt
         (F' /
          ((INR n.+1 + 1) *
           (1 + / 2 * bpow Zaux.radix2 (- fprec Tsingle + 1)) ^ (n.+1 + 1)%coq_nat) -
          / 2 * bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle)))%Re /\
      (Rabs (FT2R b) <=
       sqrt
         (F' /
          ((INR n.+1 + 1)*
           (1 + / 2 * bpow Zaux.radix2 (- fprec Tsingle + 1)) ^ (n.+1 + 1)%coq_nat) -
            / 2 * bpow Zaux.radix2 (3 - femax Tsingle - fprec Tsingle)))%Re).
{ specialize (H0 i).
  assert ((i < n.+1)%nat).
  { by rewrite size_map size_enum_ord in H1. } specialize (H0 H6).
  apply H0.
} specialize (H2 H6). clear H4 H5 H6.
destruct H2 as [ifH2 H2]. fold d e in H2.
apply Rle_trans with (e_i (@inord n i) A v).
+ unfold e_i. fold d e.
  remember (combine
                (vec_to_list_float n.+1  (\row_j A (inord i) j)^T)
                (vec_to_list_float n.+1 v)) as L.
  unfold FT2R_mat. rewrite !mxE.
  assert (\sum_j
             (\matrix_(i0, j0) FT2R (A i0 j0)) (inord i) j *
             (\matrix_(i0, j0) FT2R (v i0 j0)) j 0 =
          dot_prodR (Flist_to_Rlist_pair L)).
  { assert (\sum_j
               (\matrix_(i0, j0) FT2R (A i0 j0)) (inord i) j *
               (\matrix_(i0, j0) FT2R (v i0 j0)) j 0  =
            \sum_j (FT2R (A (@inord n i) j) * FT2R (v j 0))).
    { apply eq_big. by []. intros. by rewrite !mxE. } rewrite H4.
    assert (\sum_j FT2R (A (inord i) j) * FT2R (v j 0) =
             \sum_j FT2R ((\row_j A (inord i) j)^T j 0) * FT2R (v j 0)).
    { apply eq_big. by []. intros. by rewrite !mxE. } rewrite H5.
    pose proof (@sum_dot n n.+1 Tsingle (leqnn n.+1)) .
    specialize (H6 (\row_j0 A (inord i) j0)^T v).
    rewrite HeqL.  rewrite -H6.
    apply eq_big. by []. intros. rewrite !mxE.
    assert (widen_ord (m:=n.+1) (leqnn n.+1) i0 = i0).
    { unfold widen_ord. apply val_inj. by simpl. }
    by rewrite H8.
  } rewrite H4. rewrite -RminusE. unfold d, e. rewrite HeqL in H2.
  rewrite HeqL.
  assert (vec_to_list_float n.+1 (\col_j v j 0) = vec_to_list_float n.+1 v).
  { assert (v = \col_j v j 0).
    { apply matrixP. unfold eqrel. intros. rewrite !mxE.
      assert (y=0). { by apply ord1. } by rewrite H5.
    } by rewrite -H5.
  } rewrite H5. apply H2.
+ assert (e_i (inord i) A v =
         [seq e_i i0 A v | i0 <- enum 'I_n.+1]`_i).
  { rewrite seq_equiv nth_mkseq. nra. by rewrite size_map size_enum_ord in H1. }
  rewrite H4. apply /RleP.
  apply (@bigmaxr_ler _  _ [seq e_i i0 A v | i0 <- enum 'I_n.+1] i).
  rewrite size_map size_enum_ord.
  by rewrite size_map size_enum_ord in H1.
Qed.

End WITHNANS.


(* Function composition *)

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

Lemma funcomp_assoc {W X Y Z} (g: Y -> Z) (f: X -> Y) (h: W -> X) :
  funcomp g (funcomp f h) = (funcomp (funcomp g f) h).
Proof.
  reflexivity.
Qed.

(** ** Functor Instances

Exemplary functor instances needed to make Autosubst's generation possible for functors.
Two things are important:
1. The names are fixed.
2. For Coq to check termination, also the proofs have to be closed with Defined.
 *)

(** *** List Instance *)
Require Import List.

Definition list_ext {A B} {f g : A -> B} :
  (forall x, f x = g x) -> forall xs, map f xs = map g xs.
  intros H. induction xs. reflexivity.
  cbn. f_equal. apply H. apply IHxs.
Defined.

Definition list_id {A}  { f : A -> A} :
  (forall x, f x = x) -> forall xs, map f xs = xs.
Proof.
  intros H. induction xs. reflexivity.
  cbn. rewrite H. rewrite IHxs; eauto.
Defined.

Definition list_comp {A B C} {f: A -> B} {g: B -> C} {h} :
  (forall x, (funcomp  g f) x = h x) -> forall xs, map g (map f xs) = map h xs.
Proof.
  induction xs. reflexivity.
  cbn. rewrite <- H. f_equal. apply IHxs.
Defined.

(** *** Prod Instance *)

Definition prod_map {A B C D} (f : A -> C) (g : B -> D) (p : A * B) :
  C * D.
Proof.
  destruct p as [a b]. split.
  exact (f a). exact (g b).
Defined.

Definition prod_id {A B} {f : A -> A} {g : B -> B} :
  (forall x, f x = x) -> (forall x, g x = x) -> forall p, prod_map f g p = p.
Proof.
  intros H0 H1. destruct p. cbn. f_equal; [ apply H0 | apply H1 ].
Defined.

Definition prod_ext {A B C D} {f f' : A -> C} {g g': B -> D} :
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> forall p, prod_map f g p = prod_map f' g' p.
Proof.
  intros H0 H1. destruct p as [a b]. cbn. f_equal; [ apply H0 | apply H1 ].
Defined.

Definition prod_comp {A B C D E F} {f1 : A -> C} {g1 : C -> E} {h1 : A -> E} {f2: B -> D} {g2: D -> F} {h2 : B -> F}:
  (forall x, (funcomp  g1 f1) x = h1 x) -> (forall x, (funcomp g2 f2) x = h2 x) -> forall p, prod_map g1 g2 (prod_map f1 f2 p) = prod_map h1 h2 p.
Proof.
  intros H0 H1. destruct p as [a b]. cbn. f_equal; [ apply H0 | apply H1 ].
Defined.

(* a.d. TODO hints outside of sections without explicit locality are deprecated. Is this even used in the first place?  *)
Hint Rewrite in_map_iff : FunctorInstances.

(* Declaring the scopes that all our notations will live in *)
Declare Scope fscope.
Declare Scope subst_scope.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** A library of code for supporting LNgen. *)

Require Export Metalib.LibDefaultSimp.
Require Import Metalib.Metatheory.
Require Import Lia.

(* ********************************************************************** *)
(** * Assorted functions not in the standard library *)

(** [lt_ge_dec] is a useful comparison operation when defining the
    "close" operation on locally nameless terms. *)

Definition lt_ge_dec (n m : nat) : {n < m} + {n >= m} :=
  match Compare_dec.le_gt_dec m n with
    | left pf => right pf
    | right pf => left pf
  end.

(* *********************************************************************** *)
(** * Tactics *)

(** [generalize_wrt x] is an ad hoc tactic that generalizes the goal
    with respect to everything that [x] does not depend on.  It seems
    to work only if [x] is the most recently introduced item into the
    context. *)

Ltac generalize_wrt x :=
  repeat (progress (match goal with
    | J : _ |- _ => move J after x; generalize dependent J
    end)).

(** [apply_mutual_ind] applies to the current goal a mutual induction
    principle that is stated in the form generated by [Combined
    Scheme].  It works even in degenerate cases, i.e., when there is
    no mutual induction, only simple induction.  It is intended to be
    used only at the start of a proof, and the argument(s) to induct
    over should come first. *)

Ltac apply_mutual_ind ind :=
  match goal with
     [ |- (and _ _) ]  => apply ind
   | [ |- (prod _ _) ]  => apply ind
   | _ =>
     let H := fresh in
     first [ (* apply ind
        | *) intros H; induction H using ind
        | intros ? H; induction H using ind
        | intros ? ? H; induction H using ind
        | intros ? ? ? H; induction H using ind
        | intros ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? ? ? H; induction H using ind
        ]
     end.

(** Renames the last hypothesis to the given identifier. *)

Ltac rename_last_into H :=
  match goal with
    | J : _ |- _ => rename J into H
  end.

(** Specializes every possible hypothesis with the given term. *)

Ltac specialize_all x :=
  repeat (match goal with
            | H : _ |- _ => specialize (H x)
          end).

(* *********************************************************************** *)
(** * Facts about finite sets *)

Lemma remove_union_distrib : forall (s1 s2 : atoms) (x : atom),
  remove x (union s1 s2) [=] union (remove x s1) (remove x s2).
Proof. fsetdec. Qed.

Lemma Equal_union_compat : forall (s1 s2 s3 s4 : atoms),
  s1 [=] s3 ->
  s2 [=] s4 ->
  union s1 s2 [=] union s3 s4.
Proof. fsetdec. Qed.

Lemma Subset_refl : forall (s : atoms),
  s [<=] s.
Proof. fsetdec. Qed.

Lemma Subset_empty_any : forall (s : atoms),
  empty [<=] s.
Proof. fsetdec. Qed.

Lemma Subset_union_compat : forall (s1 s2 s3 s4 : atoms),
  s1 [<=] s3 ->
  s2 [<=] s4 ->
  union s1 s2 [<=] union s3 s4.
Proof. fsetdec. Qed.

Lemma Subset_union_left : forall (s1 s2 s3 : atoms),
  s1 [<=] s2 ->
  s1 [<=] union s2 s3.
Proof. fsetdec. Qed.

Lemma Subset_union_right : forall (s1 s2 s3 : atoms),
  s1 [<=] s3 ->
  s1 [<=] union s2 s3.
Proof. fsetdec. Qed.

Lemma Subset_union_lngen_open_upper :
  forall (s1 s2 s3 s4 s5 : atoms),
  s1 [<=] union s3 s4 ->
  s2 [<=] union s3 s5 ->
  union s1 s2 [<=] union s3 (union s4 s5).
Proof. fsetdec. Qed.

(* *********************************************************************** *)
(** * Hints *)

#[global]
Hint Resolve sym_eq : brute_force.

#[global]
Hint Extern 5 (_ = _ :> nat) => lia : brute_force.
#[global]
Hint Extern 5 (_ < _)        => lia : brute_force.
#[global]
Hint Extern 5 (_ <= _)       => lia : brute_force.

Hint Rewrite @remove_union_distrib : lngen.

#[global]
Hint Resolve @Equal_union_compat : lngen.
#[global]
Hint Resolve @Subset_refl : lngen.
#[global]
Hint Resolve @Subset_empty_any : lngen.
#[global]
Hint Resolve @Subset_union_compat : lngen.
#[global]
Hint Resolve @Subset_union_left : lngen.
#[global]
Hint Resolve @Subset_union_right : lngen.
#[global]
Hint Resolve @Subset_union_lngen_open_upper : lngen.


Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *)
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Presheaf.
Local Open Scope cat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Fiber.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.Foundations.All.

Local Open Scope type_scope.
Local Open Scope mor_disp_scope.

Section DisplayedDisplayedCategories.

Definition disp_disp_cat (C : category) : UU
  := ∑ (D : disp_cat C), disp_cat (total_category D).

Definition base_disp_cat {C : category} (E : disp_disp_cat C) : disp_cat C
  := pr1 E.

Definition top_disp_cat {C : category} (E : disp_disp_cat C)
  : disp_cat (total_category (base_disp_cat E))
  := pr2 E.

End DisplayedDisplayedCategories.

Section CompositeDisplayedCategories.

Definition composite_disp_cat_ob_mor {C : category} (DD : disp_disp_cat C)
  : disp_cat_ob_mor C.
Proof.
  destruct DD as [D E].
  use tpair.
  - intro x.
    exact (∑ xx : D x, E (x ,, xx)).
  - simpl.
    intros x y [xx xxx] [yy yyy] f.
    exact (∑ ff : xx -->[f] yy, xxx -->[(f ,, ff)] yyy).
Defined.

Definition composite_disp_cat_id_comp {C : category} (DD : disp_disp_cat C)
  : disp_cat_id_comp C (composite_disp_cat_ob_mor DD).
Proof.
  destruct DD as [D E].
  use tpair.
  - intros x [xx xxx].
    use tpair.
    + simpl.
      exact (id_disp xx).
    + simpl.
      exact (id_disp xxx).
  - simpl.
    intros x y z f g [xx xxx] [yy yyy] [zz zzz] [ff fff] [gg ggg].
    use tpair.
    + exact (ff ;; gg).
    + simpl.
      exact (fff ;; ggg).
Defined.

Definition composite_disp_cat_data {C : category} (DD : disp_disp_cat C)
  := (composite_disp_cat_ob_mor DD ,, composite_disp_cat_id_comp DD) : disp_cat_data C.

Definition composite_disp_cat_axioms {C : category} (DD : disp_disp_cat C)
  : disp_cat_axioms C (composite_disp_cat_data DD).
Proof.
  destruct DD as [D E].
  repeat split.
  - intros x y f [xx xxx] [yy yyy] [ff fff].
    use total2_reassoc_paths'.
    + simpl.
      apply id_left_disp.
    + simpl.
      apply (pathscomp0 (id_left_disp fff)).
      apply maponpaths_2.
      apply homset_property.
  - intros x y f [xx xxx] [yy yyy] [ff fff].
    use total2_reassoc_paths'.
    + simpl.
      apply id_right_disp.
    + simpl.
      eapply pathscomp0.
      * apply (id_right_disp fff).
      * apply maponpaths_2.
        apply homset_property.
  - intros x y z w f g h [xx xxx] [yy yyy] [zz zzz] [ww www] [ff fff] [gg ggg] [hh hhh].
    use total2_reassoc_paths'.
    + simpl.
      apply assoc_disp.
    + simpl.
      eapply pathscomp0.
      * apply (assoc_disp fff ggg hhh).
      * apply maponpaths_2.
        apply homset_property.
  - intros x y f [xx xxx] [yy yyy].
    apply isaset_total2.
    + apply homsets_disp.
    + intros ff.
      apply homsets_disp.
Qed.

Definition composite_disp_cat {C : category} (DD : disp_disp_cat C)
  : disp_cat C
  := (_,, composite_disp_cat_axioms DD).

End CompositeDisplayedCategories.

Section Auxiliary. (* Auxiliary lemmas for the axioms of fiber displayed categories. *)

(* analogous to UniMath.MoreFoundations.PartA.total2_reassoc_paths' for fiber instead of composite: *)
Definition total2_fiber_path {A : UU} {B : A -> UU} {C : (∑ a, B a) -> UU} (a : A)
    (Ca : B a -> UU := λ b, C (a ,, b))
    {b1 b2 : B a} (c1 : Ca b1) (c2 : Ca b2)
    (eb : b1 = b2)
    (ec : c1 = transportb C (two_arg_paths_b (idpath a) eb) c2)
  : c1 = transportb Ca eb c2.
Proof.
  destruct eb; cbn.
  destruct (! ec); cbn.
  apply idpath.
Defined.

(* the following lemma roughly means that a morphism of dependent types commutes with transport: *)
Definition mor_disp_types_comm_transp {A B : UU} (P: A → UU) (Q : B → UU)
    (f0: A → B) (f1: ∏ a : A, P a → Q(f0 a))
    {x x' : A} (h: x = x')
  : ∏ (p : P x), transportf Q (maponpaths f0 h) (f1 x p) = f1 x' (transportf P h p).
Proof.
  intro p.
  induction h.
  apply idpath.
Defined.

End Auxiliary.

Section FiberDisplayedCategories.

Definition fiber_disp_cat_ob_mor {C : category} (DD : disp_disp_cat C) (c : C)
  : disp_cat_ob_mor (base_disp_cat DD)[{c}].
Proof.
  destruct DD as [D E].
  use tpair.
  - simpl. intro x.
    exact (E (c ,, x)).
  - simpl.
    intros x y xx yy f.
    exact (xx -->[(identity c ,, f)] yy).
Defined.

Definition fiber_disp_cat_id_comp {C : category} (DD : disp_disp_cat C) (c : C)
  : disp_cat_id_comp (base_disp_cat DD)[{c}] (fiber_disp_cat_ob_mor DD c).
Proof.
  destruct DD as [D E].
  split.
  - simpl.
    intros x xx.
    apply (@id_disp _ E _ xx).
  - simpl.
    intros x y z f g xx yy zz ff gg.
    use (transportf _ _ (ff ;; gg)).
    use total2_paths_f; simpl.
    + apply id_right.
    + apply idpath.
Defined.

Definition fiber_disp_cat_data {C : category} (DD : disp_disp_cat C) (c : C)
  := (fiber_disp_cat_ob_mor DD c,, fiber_disp_cat_id_comp DD c)
  : disp_cat_data (base_disp_cat DD)[{c}].

Definition fiber_disp_cat_axioms {C : category} (DD : disp_disp_cat C) (c : C)
  : disp_cat_axioms (base_disp_cat DD)[{c}] (fiber_disp_cat_data DD c).
Proof.
  destruct DD as [D E].
  repeat split; intros; simpl.
  - simpl in *.
    use total2_fiber_path.
    unfold ";;".
    apply transportf_transpose_left.
    apply (pathscomp0 (id_left_disp ff)).
    eapply pathscomp0.
    2: { apply pathsinv0. apply transport_b_b. }
    + unfold transportb.
      apply maponpaths_2.
      apply homset_property.
  - simpl in *.
    use total2_fiber_path.
    unfold ";;".
    apply transportf_transpose_left.
    apply (pathscomp0 (id_right_disp ff)).
    eapply pathscomp0.
    2: { apply pathsinv0. apply transport_b_b. }
    unfold transportb.
    apply maponpaths_2.
    apply homset_property.
  - simpl in *.
    use total2_fiber_path.
    unfold ";;"; simpl.
    apply transportf_transpose_left.
    eapply pathscomp0.
    2: { apply pathsinv0. apply transport_b_b. }
    use pathscomp0.
    + eapply transportf.
      2: { exact (ff ;; (gg ;; hh)). }
      unfold "·"; simpl.
      use total2_paths_f; simpl.
      * apply maponpaths.
        apply id_right.
      * apply (mor_disp_types_comm_transp _ _ (λ e, identity c · e) (λ e ee, f ;; ee)).
    + eapply pathscomp0.
      * apply pathsinv0.
        unfold "·"; simpl.
        apply (mor_disp_types_comm_transp (mor_disp yy ww) (mor_disp xx ww) _ (λ e ee, ff ;; ee) (@total2_paths_f _ _ (identity c · identity c,, _) (identity c,, _) (id_right (identity c)) (idpath (transportf (mor_disp y w) (id_right (identity c)) (g ;; h)))) (gg ;; hh)).
      * apply maponpaths_2.
        apply (homset_property (total_category D) (c,, x) (c,, w)).
    + eapply pathscomp0.
      2: { apply pathsinv0. apply transport_b_f. }
      apply transportf_transpose_right.
      use pathscomp0.
      * use transportf.
        -- exact ((identity c,, f : total_category D ⟦(c,, x), (c,, y)⟧) · (identity c,, g : total_category D ⟦(c,, y), (c,, z)⟧) · (identity c,, h : total_category D ⟦(c,, z), (c,, w)⟧)).
        -- simpl.
           apply (maponpaths (λ e, pr2 (pr2 (total_category_data D)) (c,, x) (c,, z) (c,, w) e (identity c,, h))).
           use total2_paths_f; simpl.
           ++ apply id_right.
           ++ apply idpath.
        -- exact (ff ;; gg ;; hh).
      * eapply pathscomp0.
        -- apply transport_b_f.
        -- apply transportf_transpose_left.
           apply (pathscomp0 (assoc_disp ff gg hh)).
           eapply pathscomp0.
           2: { apply pathsinv0. apply transport_b_f. }
           unfold transportb.
           unfold ";;" at 1 2 9 10.
           apply maponpaths_2.
           apply (homset_property (total_category D) (c,, x) (c,, w)).
      * apply (mor_disp_types_comm_transp _ _ (λ e : total_category_data D ⟦ c,, x, c,, z ⟧, e · (identity c,, h : total_category D ⟦(c,, z), (c,, w)⟧)) (λ e ee, ee ;; hh)).
  - apply homsets_disp.
Qed.

Definition fiber_disp_cat {C : category} (DD : disp_disp_cat C) (c : C)
  : disp_cat (base_disp_cat DD)[{c}]
  := (_,, fiber_disp_cat_axioms DD c).

End FiberDisplayedCategories.


Require Import Coq.Lists.List.
Require Import Crypto.Util.PrimitiveProd.

Import Primitive.Notations.

Fixpoint hlist {A} (P : A -> Type) (ls : list A) : Type
  := match ls return Type with
     | nil => unit
     | cons x xs => P x * @hlist A P xs
     end%type.
Fixpoint split_list {A P} (ls : list (@sigT A P)) : { ls : list A & hlist P ls }
  := match ls with
     | nil => existT _ nil tt
     | cons x xs => let 'existT ls' hls' := @split_list A P xs in existT _ (cons (projT1 x) ls') (projT2 x, hls')
     end.
Fixpoint combine_hlist {A P} (ls : list A) : hlist P ls -> list (@sigT A P)
  := match ls return hlist P ls -> _ with
     | nil => fun _ => nil
     | cons x xs => fun '(Px, Pxs) => existT P x Px :: @combine_hlist A P xs Pxs
     end.


Require Import init.

Require Export tensor_power_base.
Require Import tensor_product_universal.
Require Import linear_bilinear.
Require Import module_category.
Require Import category_initterm.

Require Import list.
Require Import unordered_list.
Require Import set.
Require Import nat.

(* begin hide *)
Section TensorPowerCategory.

(* end hide *)
Context {F : CRingObj} (V : ModuleObj F).
Variable n : nat.

(* begin hide *)
Let VP := module_plus V.
Let VSM := module_scalar V.
Let VnP := module_plus (tensor_power V n).
Let VnSM := module_scalar (tensor_power V n).

Existing Instances VP VSM VnP VnSM.

(* end hide *)
Record multilinear_from := make_multilinear {
    multilinear_from_module : ModuleObj F;
    multilinear_from_f : ∀ l : list (module_V V), list_size l = n →
        module_V multilinear_from_module;
    multilinear_from_plus : ∀ l1 a b l2 eq1 eq2 eq3,
        multilinear_from_f (l1 + (a + b) ꞉ l2) eq1 =
        @plus _ (module_plus multilinear_from_module)
            (multilinear_from_f (l1 + a ꞉ l2) eq2)
            (multilinear_from_f (l1 + b ꞉ l2) eq3);
    multilinear_from_scalar : ∀ l1 a v l2 eq1 eq2,
        multilinear_from_f (l1 + (a · v) ꞉ l2) eq1 =
        @scalar_mult _ _ (module_scalar multilinear_from_module)
            a (multilinear_from_f (l1 + v ꞉ l2) eq2)
}.

Definition multilinear_from_set (f g : multilinear_from)
    (h : cat_morphism (MODULE F)
                      (multilinear_from_module f)
                      (multilinear_from_module g))
    := ∀ x (eq : list_size x = n),
        h (multilinear_from_f f x eq) = multilinear_from_f g x eq.

Definition multilinear_from_compose {F G H : multilinear_from}
    (f : set_type (multilinear_from_set G H))
    (g : set_type (multilinear_from_set F G))
    := [f|] ∘ [g|].

Lemma multilinear_from_set_compose_in {F' G H : multilinear_from} :
    ∀ (f : set_type (multilinear_from_set G H)) g,
    multilinear_from_set F' H (multilinear_from_compose f g).
Proof.
    intros [f f_eq] [g g_eq].
    unfold multilinear_from_set in *.
    unfold multilinear_from_compose; cbn.
    intros x eq.
    rewrite g_eq.
    apply f_eq.
Qed.

Lemma multilinear_from_set_id_in : ∀ f : multilinear_from,
    multilinear_from_set f f 𝟙.
Proof.
    intros f.
    unfold multilinear_from_set.
    intros x eq.
    cbn.
    reflexivity.
Qed.

Program Instance MULTILINEAR_FROM : Category := {
    cat_U := multilinear_from;
    cat_morphism f g := set_type (multilinear_from_set f g);
    cat_compose {F G H} f g := [_|multilinear_from_set_compose_in f g];
    cat_id f := [_|multilinear_from_set_id_in f];
}.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_assoc (MODULE F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_lid (MODULE F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_rid (MODULE F)).
Qed.

Definition vectors_to_power_eq {m} (l : list (module_V V)) (eq : list_size l = m)
    := tensor_power_nat_eq V eq (vectors_to_power V l).

Lemma vectors_to_power_eq_generic {m} :
    ∀ (l : list (module_V V)) (eq : list_size l = m),
    to_generic_tensor V (vectors_to_power_eq l eq) =
    to_generic_tensor V (vectors_to_power V l).
Proof.
    intros l eq.
    unfold vectors_to_power_eq.
    rewrite generic_tensor_eq_generic.
    reflexivity.
Qed.

Lemma vectors_to_power_add :
    ∀ a l (eq1 : list_size (a ꞉ l) = nat_suc n) eq2,
    vectors_to_power_eq (a ꞉ l) eq1 =
    tensor_mult V (tensor_power V _) a (vectors_to_power_eq l eq2).
Proof.
    intros a l eq1 eq2.
    apply tensor_power_eq.
    rewrite vectors_to_power_eq_generic.
    destruct eq2; cbn.
    reflexivity.
Qed.

Lemma tensor_multilinear_from_plus : ∀ l1 a b l2 eq1 eq2 eq3,
    vectors_to_power_eq (l1 + (a + b) ꞉ l2) eq1 =
    vectors_to_power_eq (l1 + a ꞉ l2) eq2 +
    vectors_to_power_eq (l1 + b ꞉ l2) eq3.
Proof.
    intros l1 a b l2 eq1 eq2 eq3.
    apply tensor_power_eq.
    rewrite vectors_to_power_eq_generic.
    clear eq1.
    unfold vectors_to_power_eq.
    destruct eq3.
    induction l1.
    -   cbn in *.
        rewrite list_conc_lid.
        unfold list_conc; cbn.
        rewrite (tensor_rdist V).
        apply (@to_generic_tensor_plus F V).
        +   reflexivity.
        +   rewrite (generic_tensor_eq_generic V _ _ eq2).
            reflexivity.
    -   cbn in *.
        inversion eq2 as [eq3].
        specialize (IHl1 eq3).
        rewrite (generic_tensor_mult_eq V (Logic.eq_refl a0) IHl1).
        rewrite tensor_ldist.
        apply (@to_generic_tensor_plus F V).
        +   reflexivity.
        +   rewrite (generic_tensor_eq_generic V _ _ eq2).
            apply generic_tensor_mult_eq; [>reflexivity|].
            rewrite generic_tensor_eq_generic.
            reflexivity.
Qed.

Lemma tensor_multilinear_from_scalar : ∀ l1 a v l2 eq1 eq2,
    vectors_to_power_eq (l1 + (a · v) ꞉ l2) eq1 =
    a · vectors_to_power_eq (l1 + v ꞉ l2) eq2.
Proof.
    intros l1 a v l2 eq1 eq2.
    apply tensor_power_eq.
    rewrite vectors_to_power_eq_generic.
    unfold vectors_to_power_eq.
    destruct eq2; cbn.
    clear eq1.
    induction l1.
    -   unfold plus; cbn.
        unfold list_conc; cbn.
        rewrite (tensor_lscalar V).
        reflexivity.
    -   cbn in *.
        rewrite list_conc_add.
        cbn.
        unfold plus at 6; cbn.
        unfold list_conc; fold (list_conc (U := module_V V)).
        cbn.
        rewrite <- (tensor_rscalar V
            (tensor_power V (list_size (list_conc l1 (v ꞉ l2))))).
        apply generic_tensor_mult_eq; [>reflexivity|].
        exact IHl1.
Qed.

Definition tensor_multilinear_from := make_multilinear
    (tensor_power V n)
    vectors_to_power_eq
    tensor_multilinear_from_plus
    tensor_multilinear_from_scalar.

(* begin hide *)
End TensorPowerCategory.

Section TensorPowerCategory.

Context {F : CRingObj} (V : ModuleObj F).
Variable n : nat.

Let UM := cring_mult F.
Let UMC := cring_mult_comm F.

Existing Instances UM UMC.

(* end hide *)
Theorem tensor_power_universal :
    @initial (MULTILINEAR_FROM V n) (tensor_multilinear_from V n).
Proof.
    unfold tensor_multilinear_from, initial; cbn.
    intros g.
    unfold multilinear_from_set; cbn.
    apply singleton_ex; [>split|].
    -   apply ex_set_type.
        nat_induction n.
        +   destruct g as [M g g_plus g_scalar]; cbn.
            pose (USM := module_scalar (cring_module F)).
            pose (UP := cring_plus F).
            pose (MP := module_plus M).
            pose (MSM := module_scalar M).
            pose (MSMO := module_scalar_id M).
            pose (MSMR := module_scalar_rdist M).
            pose (MSMC := module_scalar_comp M).
            unfold zero at 2; cbn.
            pose (x := g list_end (Logic.eq_refl 0)).
            pose (f α := α · x).
            assert (∀ u v, f (u + v) = f u + f v) as f_plus.
            {
                intros u v.
                unfold f.
                apply scalar_rdist.
            }
            assert (∀ a v, f (a · v) = a · f v) as f_scalar.
            {
                intros a v.
                unfold f.
                symmetry; apply scalar_comp.
            }
            exists (make_module_homomorphism F (cring_module F) M
                f f_plus f_scalar); cbn.
            intros l l_eq.
            destruct l; [>|inversion l_eq].
            rewrite (proof_irrelevance _ (Logic.eq_refl 0)); clear l_eq.
            fold x.
            unfold vectors_to_power_eq.
            unfold f.
            unfold vectors_to_power.
            destruct (@Logic.eq_refl nat nat_zero); cbn.
            apply scalar_id.
        +   cbn.
            clear n.
            rename n0 into n.
            pose (VP := module_plus V).
            pose (VSM := module_scalar V).
            pose (VnP := module_plus (tensor_power V n)).
            pose (VnSM := module_scalar (tensor_power V n)).
            pose (gM := multilinear_from_module V (nat_suc n) g).
            pose (gMP := module_plus gM).
            pose (gMN := module_neg gM).
            pose (gMPC := module_plus_comm gM).
            pose (gMPA := module_plus_assoc gM).
            pose (gMPZ := module_plus_lid gM).
            pose (gMPN := module_plus_linv gM).
            pose (gMSM := module_scalar gM).
            pose (gMSML := module_scalar_ldist gM).
            pose (gMSMC := module_scalar_comp gM).
            assert (∀ (a : module_V V) l,
                list_size l = n → list_size (a ꞉ l) = nat_suc n) as l_eq.
            {
                intros a l eq.
                rewrite list_size_add.
                apply f_equal.
                exact eq.
            }
            pose (f1 v l eq := multilinear_from_f V (nat_suc n) g (v ꞉ l) (l_eq _ _ eq)).
            assert (∀ v, ∀ l1 a b l2 eq1 eq2 eq3,
                f1 v (l1 + (a + b) ꞉ l2) eq1 =
                f1 v (l1 + a ꞉ l2) eq2 + f1 v (l1 + b ꞉ l2) eq3)
                as f1_plus.
            {
                intros v l1 a b l2 eq1 eq2 eq3.
                unfold f1.
                change (v ꞉ (l1 + (a + b) ꞉ l2)) with ((v ꞉ l1) + (a + b) ꞉ l2).
                change (v ꞉ (l1 + a ꞉ l2)) with ((v ꞉ l1) + a ꞉ l2).
                change (v ꞉ (l1 + b ꞉ l2)) with ((v ꞉ l1) + b ꞉ l2).
                apply multilinear_from_plus.
            }
            assert (∀ v, ∀ l1 a u l2 eq1 eq2,
                f1 v (l1 + (a · u) ꞉ l2) eq1 =
                a · f1 v (l1 + u ꞉ l2) eq2) as f1_scalar.
            {
                intros v l1 a u l2 eq1 eq2.
                unfold f1.
                change (v ꞉ (l1 + a · u ꞉ l2)) with ((v ꞉ l1) + a · u ꞉ l2).
                change (v ꞉ (l1 + u ꞉ l2)) with ((v ꞉ l1) + u ꞉ l2).
                apply multilinear_from_scalar.
            }
            pose (f2 v := make_multilinear V n
                (multilinear_from_module V (nat_suc n) g)
                (f1 v) (f1_plus v) (f1_scalar v)).
            pose (f3 v := ex_val (IHn0 (f2 v))).
            cbn in f3.
            assert (bilinear f3) as f_bil.
            {
                repeat split.
                -   intros a v1 v2.
                    unfold f3.
                    unfold ex_val.
                    destruct (ex_to_type _) as [ah ah_eq]; cbn.
                    destruct (ex_to_type _) as [h h_eq]; cbn.
                    pose proof (tensor_power_sum V v2) as [l v2_eq]; subst v2.
                    induction l as [|v l] using ulist_induction.
                    +   rewrite ulist_image_end, ulist_sum_end.
                        do 2 rewrite module_homo_zero.
                        rewrite scalar_ranni.
                        reflexivity.
                    +   rewrite ulist_image_add, ulist_sum_add.
                        do 2 rewrite module_homo_plus.
                        rewrite scalar_ldist.
                        rewrite IHl; clear IHl.
                        apply rplus; clear l.
                        destruct v as [v [α [l v_eq]]]; subst v; cbn.
                        destruct l as [l ln]; cbn.
                        do 2 rewrite module_homo_scalar.
                        unfold vectors_to_power_eq in ah_eq, h_eq.
                        rewrite ah_eq, h_eq.
                        rewrite scalar_comp.
                        rewrite mult_comm.
                        rewrite <- scalar_comp.
                        apply f_equal.
                        unfold f1.
                        apply (multilinear_from_scalar _ _ g list_end).
                -   intros a v1 v2.
                    unfold f3.
                    apply module_homo_scalar.
                -   intros v1 v2 v3.
                    unfold f3.
                    unfold ex_val.
                    destruct (ex_to_type _) as [h12 h12_eq]; cbn.
                    destruct (ex_to_type _) as [h1 h1_eq]; cbn.
                    destruct (ex_to_type _) as [h2 h2_eq]; cbn.
                    pose proof (tensor_power_sum V v3) as [l v3_eq]; subst v3.
                    induction l as [|v l] using ulist_induction.
                    +   rewrite ulist_image_end, ulist_sum_end.
                        do 3 rewrite module_homo_zero.
                        rewrite plus_lid.
                        reflexivity.
                    +   rewrite ulist_image_add, ulist_sum_add.
                        do 3 rewrite module_homo_plus.
                        rewrite IHl; clear IHl.
                        do 2 rewrite plus_assoc.
                        apply rplus.
                        rewrite <- plus_assoc.
                        rewrite (plus_comm _ (h2 [v|])).
                        rewrite plus_assoc.
                        apply rplus; clear l.
                        destruct v as [v [α  [l v_eq]]]; subst v; cbn.
                        destruct l as [l ln]; cbn.
                        do 3 rewrite module_homo_scalar.
                        unfold vectors_to_power_eq in h12_eq, h1_eq, h2_eq.
                        rewrite h12_eq, h1_eq, h2_eq.
                        rewrite <- scalar_ldist.
                        apply f_equal.
                        unfold f1.
                        apply (multilinear_from_plus _ _ g list_end).
                -   intros v1 v2 v3.
                    unfold f3.
                    apply module_homo_plus.
            }
            pose (f_base := make_bilinear V (tensor_power V n) _ f3 f_bil).
            pose proof (tensor_product_universal _ _ f_base) as f_ex.
            apply ex_singleton in f_ex as [f f_in].
            cbn in f, f_in.
            exists f.
            unfold bilinear_from_set in f_in; cbn in f_in.
            change (bilinear_from_f V _ (tensor_bilinear_from V _)) with
                (tensor_mult V (tensor_power V n)) in f_in.
            intros l eq.
            destruct l; [>inversion eq|].
            cbn.
            inversion eq as [eq2].
            rewrite (vectors_to_power_add _ _ _ _ _ eq2).
            rewrite f_in.
            unfold f3.
            unfold ex_val.
            destruct (ex_to_type _) as [h h_eq]; cbn.
            rewrite h_eq.
            unfold f1.
            rewrite (proof_irrelevance _ eq).
            reflexivity.
    -   intros [f1 f1_eq] [f2 f2_eq].
        apply set_type_eq; cbn.
        apply module_homomorphism_eq.
        intros v.
        pose proof (tensor_power_sum V v) as [l v_eq]; subst v.
        induction l as [|v l] using ulist_induction.
        +   rewrite ulist_image_end, ulist_sum_end.
            do 2 rewrite module_homo_zero.
            reflexivity.
        +   rewrite ulist_image_add, ulist_sum_add.
            do 2 rewrite module_homo_plus.
            rewrite IHl; clear IHl.
            apply rplus; clear l.
            destruct v as [v [α [l v_eq]]]; subst v; cbn.
            do 2 rewrite module_homo_scalar.
            apply f_equal.
            unfold vectors_to_power_eq in f1_eq, f2_eq.
            rewrite f1_eq, f2_eq.
            reflexivity.
Qed.
(* begin hide *)

End TensorPowerCategory.
(* end hide *)


(* From the standard library. *)
Require Import ZArith.

(* From StLib. *)
Require Import Expressions Programs.

(** A few classical domains, to reduce the boilerplate to be written by the
 * end-user. *)

Module Z1 <: DOMAIN.

  Definition cell := Z.
  Definition cexpr := aexpr.
  Definition ceval (v : vars) (c : cexpr) : cell :=
    (aeval v c).
  Definition csimpl (c : cexpr) :=
    (asimpl c).

End Z1.

Module Z2 <: DOMAIN.

  Definition cell := (Z * Z)%type.
  Definition cexpr := (aexpr * aexpr)%type.
  Definition ceval (v : vars) (c : cexpr) : cell :=
    (aeval v (fst c), aeval v (snd c)).
  Definition csimpl (c : cexpr) :=
    (asimpl (fst c), asimpl (snd c)).

End Z2.

Module Z3 <: DOMAIN.

  Definition cell := (Z * Z * Z)%type.
  Definition cexpr := (aexpr * aexpr * aexpr)%type.
  Definition ceval (v : vars) (c : cexpr) : cell :=
    (aeval v (fst (fst c)), aeval v (snd (fst c)), aeval v (snd c)).
  Definition csimpl (c : cexpr) :=
    (asimpl (fst (fst c)), asimpl (snd (fst c)), asimpl (snd c)).

End Z3.

Module Z4 <: DOMAIN.

  Definition cell := (Z * Z * Z * Z)%type.
  Definition cexpr := (aexpr * aexpr * aexpr * aexpr)%type.
  Definition ceval (v : vars) (c : cexpr) : cell :=
    (aeval v (fst (fst (fst c))), aeval v (snd (fst (fst c))),
     aeval v (snd (fst c)), aeval v (snd c)).
  Definition csimpl (c : cexpr) :=
    (asimpl (fst (fst (fst c))), asimpl (snd (fst (fst c))),
     asimpl (snd (fst c)), asimpl (snd c)).

End Z4.


Require Import ZArith.
Require Import Coq.Reals.Reals.
Require Import Coq.Reals.Rminmax.
Require Import micromega.RMicromega.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.

Require Import Helix.HCOL.CarrierType.
Require Import Helix.MSigmaHCOL.CType.
Require Import Helix.MSigmaHCOL.RasCarrierA.

Module MRasCT <: CType.

  Definition t := @CarrierA CarrierDefs_R.

  Definition CTypeEquiv := CarrierAe.
  Definition CTypeSetoid := CarrierAsetoid.
  Definition CTypeEquivDec := CarrierAequivdec.

  Definition CTypeZero  := CarrierAz.
  Definition CTypeOne   := CarrierA1.
  Definition CTypeZeroOneApart := CarrierA_Z_neq_One.
  Definition CTypePlus := CarrierAplus.

  Definition CTypeNeg   := CarrierAneg.
  Definition CTypeMult  := CarrierAmult.

  Definition CTypeAbs   := abs.
  Definition CTypeZLess := Zless.
  Definition CTypeMin   := @minmax.min CarrierA CarrierAle CarrierAledec.
  Definition CTypeMax   := @minmax.max CarrierA CarrierAle CarrierAledec.
  Definition CTypeSub   := sub.

  Definition Zless_proper := CarrierType.Zless_proper.
  Definition abs_proper := CarrierAabs_proper.
  Definition plus_proper := CarrierAPlus_proper.
  Definition sub_proper := CarrierA_sub_proper.
  Definition mult_proper := CarrierAmult_proper.
  Definition min_proper := CarrierA_min_proper.
  Definition max_proper := CarrierA_max_proper.

End MRasCT.

Global Hint Unfold
  MRasCT.CTypePlus
  MRasCT.CTypeMult
  MRasCT.CTypeSub
  MRasCT.CTypeAbs
  MRasCT.CTypeZero
  MRasCT.CTypeOne
  CarrierDefs_R
  CarrierAplus
  CarrierAmult
  CarrierType.sub
  CarrierAz
  CarrierA1 : unfold_RCT.

Require Import Coq.micromega.Psatz.
Require Import Helix.Tactics.StructTactics.

Lemma RCT_abs_Rabs (x : R) :
  MRasCT.CTypeAbs x ≡ Rabs x.
Proof.
  reflexivity.
Qed.

Lemma RCT_max_Rmax (x y : R) :
  MRasCT.CTypeMax x y ≡ Rmax x y.
Proof.
  cbv.
  repeat break_if; cbn.
  all: solve [intuition].
Qed.

Lemma R_MaxZeroAbs (x : R) :
  MRasCT.CTypeMax MRasCT.CTypeZero (MRasCT.CTypeAbs x)
  ≡ (MRasCT.CTypeAbs x).
Proof.
  rewrite RCT_abs_Rabs, RCT_max_Rmax.
  cbv.
  repeat break_if.
  all: solve [intuition].
Qed.

Lemma R_PlusZeroLeft (x : R) :
  MRasCT.CTypePlus MRasCT.CTypeZero x ≡ x.
Proof.
  cbv; lra.
Qed.

Lemma R_MultOneLeft (x : R) :
  MRasCT.CTypeMult MRasCT.CTypeOne x ≡ x.
Proof.
  cbv; lra.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Bool ZMulOrder NZParity.

(** Some more properties of [even] and [odd]. *)

Module Type ZParityProp (Import Z : ZAxiomsSig')
                        (Import ZP : ZMulOrderProp Z).

Include NZParityProp Z Z ZP.

Lemma odd_pred : forall n, odd (P n) = even n.
Proof.
 intros. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ.
Qed.

Lemma even_pred : forall n, even (P n) = odd n.
Proof.
 intros. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ.
Qed.

Lemma even_opp : forall n, even (-n) = even n.
Proof.
 assert (H : forall n, Even n -> Even (-n)).
  intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv.
 intros. rewrite eq_iff_eq_true, !even_spec.
 split. rewrite <- (opp_involutive n) at 2. apply H.
 apply H.
Qed.

Lemma odd_opp : forall n, odd (-n) = odd n.
Proof.
 intros. rewrite <- !negb_even. now rewrite even_opp.
Qed.

Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m).
Proof.
 intros. now rewrite <- add_opp_r, even_add, even_opp.
Qed.

Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m).
Proof.
 intros. now rewrite <- add_opp_r, odd_add, odd_opp.
Qed.

End ZParityProp.


Require Export FunctorCategory Functor.Pointwise.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope morphism_scope.
Local Open Scope category_scope.
Local Open Scope functor_scope.
Local Open Scope natural_transformation_scope.

Section PointwiseNaturalTransformation.
  Context `{Funext}.

  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable C' : PreCategory.
  Variable D' : PreCategory.

  Local Ltac t :=
    nt_eq; simpl;
    rewrite <- ?FCompositionOf;
    try apply ap;
    first [ apply Commutes
          | symmetry; apply Commutes ].

  Definition PointwiseNaturalTransformation1
             (F G : Functor C D)
             (T : NaturalTransformation F G)
             (F' : Functor C' D')
  : NaturalTransformation [F, F'] [G, F'].
  Proof.
    refine (Build_NaturalTransformation
              [F, F'] [G, F']
              (fun f : Object [D, C'] => F' ∘ f ∘ T)%natural_transformation
              _).
    abstract t.
  Defined.

  Definition PointwiseNaturalTransformation2
             (F : Functor C D)
             (F' G' : Functor C' D')
             (T' : NaturalTransformation F' G')
  : NaturalTransformation [F, F'] [F, G'].
  Proof.
    refine (Build_NaturalTransformation
              [F, F'] [F, G']
              (fun f : Object [D, C'] => T' ∘ f ∘ F)%natural_transformation
              _).
    abstract t.
  Defined.
End PointwiseNaturalTransformation.

Section notations.
  (** We do some black magic with typeclasses to make notations play
      well.  The cost is extra verbosity, but it will all disappear
      with [simpl]. *)

  Global Class PNT `{Funext} A B (a : A) (b : B) (T : Type) (term : T) := {}.

  Definition PNT_term `{@PNT H A B a b T term} := term.
  Global Arguments PNT_term / .

  Global Instance PNT_Functor_Functor `{Funext} C D C' D' F G
  : PNT F G (@PointwiseFunctor _ C D C' D' F G) | 1000.

  Global Instance PNT_Functor_NT `{Funext} C D C' D' F G T F'
  : PNT T F' (@PointwiseNaturalTransformation1 _ C D C' D' F G T F') | 10.

  Global Instance PNT_NT_Functor `{Funext} C D C' D' F F' G' T'
  : PNT F T' (@PointwiseNaturalTransformation2 _ C D C' D' F F' G' T') | 10.
End notations.

Hint Unfold PNT_term : typeclass_instances.

(* Set some notations for printing *)
Notation "[ F , G ]" := (PointwiseFunctor F G) : natural_transfomation_scope.
Notation "[ T , F ]" := (PointwiseNaturalTransformation1 T F) : natural_transformation_scope.
Notation "[ F , T ]" := (PointwiseNaturalTransformation2 F T) : natural_transformation_scope.

(* Notation for parsing *)
Notation "U ^ T"
  := (@PNT_term _ _ _ T%natural_transformation U%natural_transformation _ _ _)
     : natural_transformation_scope.

Notation "[ T , U ]"
  := (@PNT_term _ _ _ T%natural_transformation U%natural_transformation _ _ _)
     : natural_transformation_scope.


From hydras Require Import T1 E0.
From Coq Require Import Lia.

Open Scope E0_scope.

Lemma ge_omega_iff (alpha : E0):
  E0omega o<= alpha <-> (forall i:nat, i + alpha = alpha).
Proof.
  destruct alpha as [a Ha]; unfold E0le; cbn.
  destruct a; cbn; split; intros H.
  - rewrite Le_iff in H; destruct H as (H, (Hle, Hnf)).
    now apply le_zero_inv in Hle.
  - specialize (H 1); compute in H; now injection H.
  - intros i; apply E0_eq_intro.
    destruct i; auto.
    destruct a1; auto.
    rewrite Le_iff in H; cbn in H.
    destruct H, H0; rewrite le_lt_eq in H0.
    destruct H0; discriminate.
  - destruct a1.
    + specialize (H 1); cbn in H.
      assert (a2 = zero) by (eapply nf_of_finite; eauto).
      subst; compute in H; inversion H; lia.
    + rewrite  Le_iff; cbn.
      apply LE_trans with (T1.phi0 (cons a1_1 n0 a1_2)).
      * repeat split; auto.
        apply T1.phi0_mono; apply  le_trans with (cons a1_1 0 zero).
        -- apply T1.phi0_mono; auto with T1.
        -- apply le_phi0.
        -- apply nf_phi0; eauto with T1.
      * repeat split; eauto with T1.
        apply le_phi0.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defparallel_1 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_2 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable lemma_collinearorder_3 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defcollinear_4 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_5 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_6 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_7 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_8 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_9 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_10 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable defmeet_11 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_12 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).

Theorem lemma_parallelNC_13 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import
  Coq.Classes.CMorphisms
  Algebra.SetsC
  Algebra.OrderC
  Algebra.PreOrder
  FormTopC.FormTop
  FormTopC.FormalSpace
  FormTopC.Cont.

Set Universe Polymorphism.
Set Asymmetric Patterns.

Local Open Scope FT.
Local Open Scope Subset.

Module Lift.

Section Lift.

Variable (S : IGt).

Definition lift_subset (U : Subset S) : Subset (option S) :=
  fun ms => match ms with
    | Some x => In U x
    | None => False
  end.

Definition unlift_subset (U : Subset (option S)) : Subset S :=
  fun s => U (Some s).

Definition le (mx my : option S) : Type := match my with
  | None => True
  | Some y => match mx with
    | None => False
    | Some x => x <=[S] y
    end
  end.

Local Instance PreO_le : PreO.t le.
Proof.
constructor; intros.
- destruct x; simpl; auto. reflexivity.
- destruct x, y, z; simpl in *;
    constructor || contradiction ||
  (etransitivity ; eassumption) || eassumption.
Qed.

Definition Ix (ma : option S) : Type := match ma with
  | Some a => PreISpace.Ix S a
  | None => False
  end.

Definition C (ma : option S) : Ix ma -> Subset (option S) :=
  match ma as ma' return Ix ma' -> _ with
  | Some a => fun i => lift_subset (PreISpace.C S a i)
  | None => fun contra => False_rect _ contra
  end.

Definition LiftedPO : PreOrder :=
  {| PO_car := option S
   ; PreOrder.le := le
  |}.

Definition Lifted : PreISpace.t :=
  {| PreISpace.S := LiftedPO
   ; PreISpace.Ix := Ix
   ; PreISpace.C := C
  |}.

Local Instance loc (H : FormTop.localized S) : FormTop.localized Lifted.
Proof.
unfold FormTop.localized in *.
intros. destruct c; try contradiction.
destruct a; try contradiction.
destruct (H p0 p X i).
exists x. simpl.  intros. simpl in X.
intros u Pu. destruct u; try contradiction.
simpl in Pu. destruct (i0 _ Pu). clear i0.
le_downH d. destruct d0.
split. le_down. assumption.
exists (Some a). unfold In. simpl. assumption. assumption.
Qed.

Inductive bottom : Subset (option S) :=
  | MkBottom : bottom None.

Theorem Cov_None V : None <|[toPSL Lifted] V -> In V None.
Proof.
intros cov. remember None as none.
induction cov; subst; simpl in *; try contradiction; auto.
- destruct b; simpl in *. contradiction.
  apply IHcov. reflexivity.
- induction b; simpl in *; contradiction.
Qed.

Theorem pt_bottom : Cont.pt (toPSL Lifted) bottom.
Proof.
constructor.
- constructor 1 with None. constructor.
- intros b c X X0. induction X, X0.
  constructor 1 with None.
  repeat (econstructor || eauto).
- intros. constructor 1 with None.
  destruct X; try contradiction.
  constructor. constructor. apply Cov_None. assumption.
Qed.

Definition inj : Cont.map S (toPSL Lifted) := fun my x => match my with
  | None => True
  | Some y => x <=[S] y
  end.

Local Open Scope Subset.

Lemma inj_lift V x : In (union (lift_subset V) inj) x ->
  x <|[S] V.
Proof. intros X. destruct X. unfold In in *.
destruct a; simpl in *. apply FormTop.le_left with p.
assumption. apply FormTop.refl. assumption.
contradiction.
Qed.

Theorem inj_cont : Cont.t S (toPSL Lifted) inj.
Proof.
constructor; intros.
- apply FormTop.refl. constructor 1 with None.
  constructor. simpl. constructor.
- destruct b; simpl in *.
  etransitivity; eassumption. constructor.
- apply FormTop.refl. destruct b; simpl in *.
  + constructor 1 with (Some a).
    split; le_down; assumption. simpl. reflexivity.
  + destruct c; simpl in *.
    * constructor 1 with (Some a). split; le_down; assumption.
      simpl. reflexivity.
    * constructor 1 with None. split; le_down; constructor.
      simpl. constructor.
- destruct b; simpl in *.
  + remember (Some p) as somes.
    assert (le (Some a) somes). subst. simpl. assumption. clear Heqsomes.
    clear X.
    generalize dependent a.
    induction X0; intros.
    * destruct a; simpl in *.
      { apply FormTop.le_left with p0. assumption.
        apply FormTop.refl. constructor 1 with (Some p0).
        assumption. simpl. reflexivity. }
      { apply FormTop.glrefl. constructor 1 with None.
      assumption. simpl. assumption. }
    * apply IHX0. etransitivity; eassumption.
    * destruct a; try contradiction.
      simpl in *.
      apply FormTop.le_left with p0. assumption.
      destruct b. simpl in l.
      simpl in i.
      apply FormTop.gle_infinity with p1 i. assumption.
      intros. destruct X0. le_downH d. destruct d0.
      eapply X. split. le_down. instantiate (1 := Some u).
      eassumption. exists (Some a). simpl. unfold In.
      simpl. assumption. simpl. assumption. reflexivity.
      induction i.
      induction b; simpl in *; contradiction.
  + apply FormTop.glrefl. constructor 1 with None.
    apply Cov_None. assumption. simpl. constructor.
Qed.

End Lift.

End Lift.


Require Import Coq.NArith.NArith.
Require Import Coq.Lists.List.
Require Import liblayers.lib.Decision.
Require Export liblayers.logic.Structures.
Require Export liblayers.logic.LayerData.

(** * Pseudo-joins and some properties *)

Class PseudoJoin A `{Ale: Le A} `{Aoplus: Oplus A} (lb: A): Prop :=
  {
    oplus_preorder :>
      PreOrder (≤);
    oplus_lower_bound :>
      LowerBound (≤) lb;
    oplus_monotonic :>
      Proper ((≤) ==> (≤) ==> (≤)) (⊕);
    oplus_id_left_le :>
      LeftIdentity (≤) (⊕) lb;
    oplus_assoc_le:
      Associative (≤) (⊕);
    oplus_comm_le:
      Commutative (≤) (⊕);
    oplus_le_left :>
      LeftUpperBound (≤) (⊕)
  }.

Global Instance oplus_params:
  Params (@oplus) 2.

(** By default, we want associativity to be used in terms of [≡],
  because it can be used for rewriting regardless of variance.
  This is why [oplus_assoc_le] above is not declared as an instance.
  Note that the [≤] version (as well as [flip (≤)]) can be recovered
  by following the [subrelation] instances. *)
Section EQUIV_INSTANCES.
  Local Existing Instance oplus_assoc_le.
  Local Existing Instance oplus_comm_le.
  Local Existing Instance le_equiv_assoc.
  Local Existing Instance le_equiv_comm.

  Global Instance oplus_assoc_equiv `{PseudoJoin}:
    Associative (≡) (⊕) := _.
  Global Instance oplus_assoc_comm `{PseudoJoin}:
    Commutative (≡) (⊕) := _.
End EQUIV_INSTANCES.

(** Sometimes we need those in terms of [eq]. *)

Global Instance oplus_id_left `{PseudoJoin} `{HA: !Antisymmetric A eq (≤)}:
  LeftIdentity eq (⊕) lb.
Proof.
  intros x.
  apply antisymmetry.
  apply id_left.
  apply right_upper_bound.
Qed.

Global Instance oplus_comm `{PseudoJoin} `{HA: !Antisymmetric A eq (≤)}:
  Commutative eq (⊕).
Proof.
  intros x y.
  apply antisymmetry; apply commutativity.
Qed.

(** Combined, specialized versions of associativity, used to
  accelerate tactics. *)

Lemma oplus_assoc_equiv2 `{PseudoJoin} x y y2 z:
  ((x ⊕ y) ⊕ y2) ⊕ z ≡ x ⊕ (y ⊕ (y2 ⊕ z)).
Proof.
  rewrite associativity.
  rewrite associativity.
  reflexivity.
Qed.

Lemma oplus_assoc_equiv3 `{PseudoJoin} x y y2 y3 z:
  (((x ⊕ y) ⊕ y2) ⊕ y3) ⊕ z ≡ x ⊕ (y ⊕ (y2 ⊕ (y3 ⊕ z))).
Proof.
  rewrite oplus_assoc_equiv2.
  rewrite associativity.
  reflexivity.
Qed.

(*
          Lemma oplus_assoc_equiv4 `{PseudoJoin} x y y2 y3 y4 z:
            ((((x ⊕ y) ⊕ y2) ⊕ y3) ⊕ y4) ⊕ z ≡ x ⊕ (y ⊕ (y2 ⊕ (y3 ⊕ (y4 ⊕ z)))).
          Proof.
            rewrite oplus_assoc_equiv3.
            rewrite associativity.
            reflexivity.
          Qed.
 *)

Ltac oplus_assoc_simpl_term T:=
  lazymatch T with
(*| ((((?x ⊕ ?y) ⊕ ?y2) ⊕ ?y3) ⊕ ?y4) ⊕ ?z => rewrite (oplus_assoc_equiv4 x y y2 y3 y4 z)*)
| (((?x ⊕ ?y) ⊕ ?y2) ⊕ ?y3) ⊕ ?z => rewrite (oplus_assoc_equiv3 x y y2 y3 z)
| ((?x ⊕ ?y) ⊕ ?y2) ⊕ ?z => rewrite (oplus_assoc_equiv2 x y y2 z)
| (?x ⊕ ?y) ⊕ ?z => rewrite (oplus_assoc_equiv x y z)
end.

Lemma oplus_assoc_comm_equiv `{PseudoJoin} x y z:
  (x ⊕ y) ⊕ z ≡ y ⊕ (x ⊕ z).
Proof.
  rewrite (commutativity x y).
  rewrite associativity.
  reflexivity.
Qed.

(** * Data-indexed version *)

Class SimPseudoJoin V E T
    `{VErg: CategoryOps V E}
    `{Tsim: Sim V E T}
    `{Toplus: forall v, Oplus (T v)}
    (lb: forall v, T v): Prop :=
  {
    oplus_sim_quiv_sim :>
      CategorySim V E T;
    oplus_sim_lower_bound v1 v2 e x :>
      Convertible x (lb v1) ->
      @LowerBound (T v1) (T v2) (simRR v1 v2 e) x;
    oplus_sim_monotonic :>
      Monotonic
        (fun v => (@oplus (T v) _))
        (forallr R, sim R ++> sim R ++> sim R);
    oplus_sim_id_left_le v x :>
      Convertible x (lb v) ->
      LeftIdentity (sim id) (⊕) x;
    oplus_sim_assoc_le v:
      @Associative (T v) (sim id) (⊕);
    oplus_sim_comm_le v:
      @Commutative (T v) (sim id) (⊕);
    oplus_sim_le_left v :>
      @LeftUpperBound (T v) (sim id) (⊕)
  }.

Local Existing Instance cat_sim_cat.

(** XXX: Because of its form, [oplus_sim_monotonic] cannot be resolved
  by the [monotonicity] tactic or setoid rewriting. For the [id] case,
  we can work around this with an explicitely specialized instance. *)
Global Instance oplus_le_monotonic `{SimPseudoJoin} v:
  @Proper (T v -> T v -> T v) (sim id ++> sim id ++> sim id) (⊕).
Proof.
  apply oplus_sim_monotonic.
Qed.

Section SIM_EQUIV_INSTANCES.
  Local Existing Instance oplus_sim_assoc_le.
  Local Existing Instance oplus_sim_comm_le.
  Local Existing Instance le_equiv_assoc.
  Local Existing Instance le_equiv_comm.

  Global Instance oplus_sim_assoc_equiv `{SimPseudoJoin} D:
    @Associative (T D) (≡) (⊕) := _.
  Global Instance oplus_sim_comm_equiv `{SimPseudoJoin} D:
    @Commutative (T D) (≡) (⊕) := _.
End SIM_EQUIV_INSTANCES.

Global Instance oplus_sim_id_left `{SimPseudoJoin} D:
  Antisymmetric (T D) eq (≤) ->
  @LeftIdentity (T D) eq (⊕) (lb D).
Proof.
  intros Hantisym y.
  apply antisymmetry.
  apply id_left.
  apply right_upper_bound.
Qed.

Global Instance oplus_sim_comm `{SimPseudoJoin} D:
  Antisymmetric (T D) eq (≤) ->
  @Commutative (T D) eq (⊕).
Proof.
  intros Hantisym x y.
  apply antisymmetry; apply commutativity.
Qed.

(** ** Deriving the [PseudoJoin]s on [(T D)] *)

Global Instance sim_pseudojoin `(SimPseudoJoin):
  forall D, PseudoJoin (T D) (lb D).
Proof.
  intros D; split; typeclasses eauto.
Qed.

(** ** A more complete join *)

Section SIMJOIN.
  Context {V E T} `{HVET: CategorySim V E T}.
  Context `{Top: forall v, Oplus (T v)}.

  Class SimLUB v (x y z: T v) :=
    {
      hlub_ub_l: sim id x z;
      hlub_ub_r: sim id y z;
      hlub_intro v' (e: E v v') t: sim e x t -> sim e y t -> sim e z t
    }.

  Class SimJoin :=
    is_join v x y :> SimLUB v x y (x ⊕ y).

  Context `{Hop: !SimJoin}.

  Local Instance simjoin_sim v1 v2 (e: E v1 v2):
    Monotonic (⊕) (sim e ++> sim e ++> sim e).
  Proof.
    repeat rstep.
    apply hlub_intro.
    + htransitivity y; eauto.
      apply hlub_ub_l.
    + htransitivity y0; eauto.
      eapply hlub_ub_r.
  Qed.

  Local Instance simjoin_pjoin (bot: forall v, T v):
    (forall v1 v2 e, LowerBound (simRR v1 v2 e) (bot v1)) ->
    SimPseudoJoin V E T bot.
  Proof.
    split.
    - assumption.
    - intros v1 v2 e x Hx.
      rewrite Hx.
      eauto.
    - rauto.
    - intros v x Hx.
      rewrite Hx; clear x Hx.
      intros x.
      eapply hlub_intro.
      + eapply lower_bound.
      + reflexivity.
    - intros v x y z.
      eapply hlub_intro.
      + apply hlub_intro.
        * apply hlub_ub_l.
        * transitivity (y ⊕ z).
          apply hlub_ub_l.
          apply hlub_ub_r.
      + transitivity (y ⊕ z).
        * apply hlub_ub_r.
        * apply hlub_ub_r.
    - intros v x y.
      apply hlub_intro.
      + eapply hlub_ub_r.
      + eapply hlub_ub_l.
    - intros v x y.
      eapply hlub_ub_l.
  Qed.
End SIMJOIN.

Arguments SimJoin V E T {_ _ _}.

(** * Normalization procedure *)

(*
(** Merge sort *)

Ltac lmerge tac l1 l2 :=
  lazymatch l1 with
    | nil => tac l2
    | ?i ↦ ?x :: ?xs =>
      lazymatch l2 with
        | nil => tac l1
        | ?j ↦ ?y :: ?ys =>
          (ensure (Pos.le i j);
           let cont t := tac (i ↦ x :: t) in
           lmerge cont xs (j ↦ y :: ys)) ||
          (let cont t := tac (j ↦ y :: t) in
           lmerge cont (i ↦ x :: xs) ys)
      end
  end.

Ltac lsort tac t :=
  lazymatch t with
    | ?t1 ⊕ ?t2 =>
      let cont1 t1' :=
        let cont2 t2' :=
          lmerge tac t1' t2' in
        lsort cont2 t2 in
      lsort cont1 t1
    | ?t0 =>
      tac (t0::nil)
  end.

Ltac lfold tac l :=
  lazymatch l with
    | ?x::nil => tac x
    | ?x::?xs => let cont t := tac (x ⊕ t) in lfold cont xs
    | nil => tac ∅
  end.

Ltac lnorm tac t :=
  let cont l := lfold tac l in
  lsort cont t.

Ltac oplus_normalize_in_goal M :=
  let cont M' := (
    let H := fresh "H" in
    cut (M ≡ M');
    [intro H; try rewrite H at 1; clear H|] ||
    fail 10) in
  lnorm cont M.

Ltac peelright i x tac oplus_monotonic oplus_sim_monotonic
                       left_upper_bound right_upper_bound :=
  match goal with
    | |- ?R _ (?j ↦ ?y ⊕ ?ys) =>
      ensure (i = j);
      (apply oplus_monotonic || apply oplus_sim_monotonic); [|
        tac oplus_monotonic oplus_sim_monotonic left_upper_bound right_upper_bound
      ]
    | |- ?R _ (?j ↦ ?y) =>
      idtac
    | |- ?R _ (?a ⊕ ?b) =>
      rewrite <- (right_upper_bound a b);
      tac oplus_monotonic oplus_sim_monotonic left_upper_bound right_upper_bound
  end.

Ltac peelone i x left_upper_bound right_upper_bound :=
  match goal with
    | |- ?R _ (?j ↦ ?y ⊕ ?ys) =>
      ensure (i = j); apply left_upper_bound
    | |- ?R _ (?j ↦ ?y) =>
      idtac
    | |- ?R _ (?a ⊕ ?b) =>
      rewrite <- (right_upper_bound a b);
      peelone i x left_upper_bound right_upper_bound
  end.

Ltac peelsim oplus_monotonic oplus_sim_monotonic
             left_upper_bound right_upper_bound :=
  lazymatch goal with
    | |- ?R (?i ↦ _) (?i ↦ _) =>
      idtac
    | |- ?R (?i ↦ ?x ⊕ ?xs) _ =>
      peelright i x peelsim oplus_monotonic oplus_sim_monotonic
                            left_upper_bound right_upper_bound
    | |- ?R (?i ↦ ?x) _ =>
      peelone i x left_upper_bound right_upper_bound
    | |- _ =>
      idtac
  end.

Ltac sim_split oplus_monotonic oplus_sim_monotonic
               left_upper_bound right_upper_bound :=
  lazymatch goal with
    | |- ?R ?X ?Y =>
      lazymatch type of R with
        | ?TX -> ?TY -> Prop =>
          oplus_normalize_in_goal (X : TX); [
          oplus_normalize_in_goal (Y : TY); [
          peelsim oplus_monotonic oplus_sim_monotonic
                  left_upper_bound right_upper_bound |] |]
        | rel ?TX ?TY =>
          oplus_normalize_in_goal (X : TX); [
          oplus_normalize_in_goal (Y : TY); [
          peelsim oplus_monotonic oplus_sim_monotonic
                  left_upper_bound right_upper_bound |] |]
        | relation ?T =>
          oplus_normalize_in_goal (Y : T); [
          oplus_normalize_in_goal (X : T); [
          peelsim oplus_monotonic oplus_sim_monotonic
                  left_upper_bound right_upper_bound |] |]
      end
  end.

Section TEST.
  Context `{SimPseudoJoin}.
  Context `{forall D, Mapsto positive positive (T D)}.
  Local Open Scope positive.

  Goal forall D1 D2 R, simRR D1 D2 R (1 ↦ 42 ⊕ 20 ↦ 3 ⊕ 2 ↦ 1) (30 ↦ 7 ⊕ 20 ↦ 4 ⊕ 2 ↦ 42 ⊕ 1 ↦ 18).
    intros.
    sim_split (oplus_monotonic (A := T D1)) oplus_sim_monotonic
              left_upper_bound right_upper_bound.
  Abort.
End TEST.
*)

(** * Booleans have a pseudo-join structure *)

Global Instance bool_oplus : Oplus bool := { oplus := orb }.

Global Instance bool_pjoin : PseudoJoin bool false.
Proof.
  split; typeclasses eauto.
Qed.

(** * Product of pseudo-join structures *)

Section PSEUDOJOIN_PROD.
  Context {A Ale Aoplus Alb} `{HA: @PseudoJoin A Ale Aoplus Alb}.
  Context {B Ble Boplus Blb} `{HB: @PseudoJoin B Ble Boplus Blb}.

  Local Instance prod_le_op : Le (A * B) :=
    { le := (≤) * (≤) }.

  Local Instance prod_oplus: Oplus (A * B)%type :=
    {
      oplus x y :=
        match x, y with
          | (xa, xb), (ya, yb) => (xa ⊕ ya, xb ⊕ yb)
        end
    }.

  Local Instance prod_pjoin : PseudoJoin (A * B)%type (Alb, Blb).
  Proof.
    split.
    * simpl.
      typeclasses eauto.
    * intros [a b].
      constructor;
      apply lower_bound.
    * intros [xa1 xb1] [xa2 xb2] [Hxa Hxb] [ya1 yb1] [ya2 yb2] [Hya Hyb].
      simpl in *.
      solve_monotonic.
    * intros [a b].
      constructor; simpl;
        apply id_left.
    * intros [xa xb] [ya yb] [za zb].
      constructor; simpl;
        apply associativity.
    * intros [xa xb] [ya yb].
      unfold oplus;
        simpl.
      split; simpl; apply commutativity.
    * intros [xa xb] [ya yb].
      constructor; simpl;
        apply left_upper_bound.
  Qed.
End PSEUDOJOIN_PROD.

(** * Adjoining an extra element *)

Definition extension A := (A * bool)%type.

Section PSEUDOJOIN_EXTENSION.
  Context `{PseudoJoin}.

  Definition ext_le: relation (extension A) :=
    (≤) * leb.

  Definition ext_inj (a: A): extension A :=
    (a, false).

  Definition ext_elem: extension A :=
    (lb, true).

  Definition ext_map {B} (f: A -> B) (x: extension A): extension B :=
    match x with (a, b) => (f a, b) end.

  Local Instance ext_le_op : Le (extension A) := prod_le_op.
  Local Instance ext_oplus : Oplus (extension A) := prod_oplus.
  Local Instance ext_pjoin : PseudoJoin (extension A) (ext_inj lb) := prod_pjoin.
End PSEUDOJOIN_EXTENSION.